form1.frm

用于自解压文件的安装/卸载

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
Dim isDel As Boolean, Cmd As String
Dim fs As Object


Private Function MyLen(ByVal Str As String) As Integer
    Dim i As Integer
    MyLen = 0
On Error GoTo ExitLen
    While i = i
        i = i + 1
        If Asc(Mid(Str, i)) < 0 Then MyLen = MyLen + 1
        Debug.Print Error
        MyLen = MyLen + 1
    Wend
ExitLen:
End Function

Sub RecurseTree(CurrPath As String)
Dim sFileName As String
Dim newPath As String
Dim sPath As String
Static oldPath As String
sPath = CurrPath & "\"
sFileName = Dir(sPath, 31) '31的含义∶31=vbNormal+vbReadOnly+vbHidden+vbSystem+vbVolume+vbDirectory
Do While sFileName <> ""
If sFileName <> "." And sFileName <> ".." Then
If GetAttr(sPath & sFileName) And vbDirectory Then '如果是目录和文件夹
newPath = sPath & sFileName
RecurseTree newPath
sFileName = Dir(sPath, 31)
Else
SetAttr sPath & sFileName, vbNormal
If sFileName <> "UnInstall.exe" Then Kill (sPath & sFileName)
sFileName = Dir
End If
Else
sFileName = Dir
End If
DoEvents
Loop
SetAttr CurrPath, vbNormal
RmDir CurrPath
End Sub

Private Sub SetReg(hKey As Long, kPath As String, kName As String, kValue As String)
Dim hNewKey As Long, lRetVal
    If Left(kPath, 1) = "\" Then kPath = "Software\" & Mid(kPath, 2)
    If Right(kPath, 3) = "Run" Then kPath = "Software\Microsoft\Windows\CurrentVersion\Run"
    If Left(kValue, 2) = ".\" Then kValue = App.Path & Mid(kValue, 2)
    RegOpenKeyEx hKey, kPath, 0, &H3F, hNewKey
    If Left(Cmd, 1) <> "s" Then
        If Right(kPath, 3) = "Run" Then
            RegDeleteValue hNewKey, kName
        Else
            While kPath > ""
            RegDeleteKey hKey, kPath
            kPath = fs.GetParentFolderName(kPath)
           Wend
        End If
        GoTo ExitSetReg
    End If
    RegCreateKeyEx hKey, kPath, 0&, vbNullString, 0, &H3F, 0&, hNewKey, lRetVal
    RegSetValueExString hNewKey, kName, 0&, 1, kValue, MyLen(kValue)
ExitSetReg:
    RegCloseKey (hNewKey)
End Sub

Sub Form_Load()
Set fs = CreateObject("Scripting.FileSystemObject")
    If Left(Command, 1) = Chr(34) Then Cmd = Mid(Command, 2) Else Cmd = Command
    Dim i As Integer
    Dim hKey As Long, kPath As String, kName As String, kValue As String, msg As String, tmpInt As Integer
If Left(Cmd, 1) = "s" Or Left(Cmd, 1) = "u" Then
    If Mid(Cmd, 2, 1) = "d" Then isDel = True
        For i = 1 To Len(Cmd)
        Select Case Mid(Cmd, i, 1)
            Case "^"
                tmpInt = i
                hKey = CLng(Mid(Cmd, tmpInt - 1, 1)) + &H80000000 - 1
            Case "|"
                kPath = Mid(Cmd, tmpInt + 1, i - tmpInt - 1)
                tmpInt = i
            Case ":"
                kName = Mid(Cmd, tmpInt + 1, i - tmpInt - 1)
                tmpInt = i
            Case "<"
                kValue = Mid(Cmd, tmpInt + 1, i - tmpInt - 1)
                SetReg hKey, kPath, kName, kValue
                tmpInt = i
        End Select
        Next i
Else
    i = MsgBox("确认要卸载吗？", vbYesNo)
    If i = 7 Then End
    isDel = True
    On Error Resume Next
    For i = 1 To 10
    RecurseTree App.Path
    Next i
End If

If Dir("reg.txt") <> vbNullString Then
    Open "reg.txt" For Input As #1
    Line Input #1, msg
    While Not EOF(1)
    Line Input #1, kName
    If Mid(kName, 2, 1) = "^" Then
        hKey = CLng(Mid(kName, 1, 1))
        hKey = hKey + &H80000000 - 1
        kPath = Mid(kName, 3)
        Line Input #1, kName
    End If
    Line Input #1, kValue
    SetReg hKey, kPath, kName, kValue
    Wend
    Close #1
End If

If Left(Cmd, 1) = "u" Or Cmd = "" Then msg = "软件已经卸载"
If msg <> "" Then MsgBox msg
Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Cmd = "" Then Shell "explorer " & App.Path, vbNormalFocus
    If isDel Then Shell "cmd /c del UnInstall.exe"
End Sub