VB 在EXE后附加信息

  1 '-------------------------------------
  2 '在EXE后附加信息
  3 'by 风飞雪 QQ:270204069 suuo@qq.com
  4 '2009-7-25
  5 '转载请保留注释
  6 '-------------------------------------
  7 Option Explicit
  8 Private Const ExeInfoLen = 400 'exe文件后附加信息总长度
  9 Public Function WriteEXE(resFile() As Byte, FileName As String, info As String, infolen As Long) As Boolean
 10 On Error GoTo Err
 11     Dim TempByte As Byte
 12     Dim UserData() As Byte
 13     Dim FileNum As Integer
 14     Dim I As Long
 15     ReDim UserData(infolen)
 16 
 17     FileNum = FreeFile
 18     Open FileName For Binary Access Write As #FileNum
 19     Put #FileNum, , resFile
 20     
 21     For I = 1 To Len(info)
 22         UserData(I) = Asc(Mid(info, I, 1))
 23     Next I
 24     If Len(info) < infolen Then
 25         For I = Len(info) + 1 To infolen
 26             UserData(I) = Asc(" ")
 27         Next I
 28     End If
 29     Put #FileNum, , UserData
 30     Close #FileNum
 31     WriteEXE = True
 32     Exit Function
 33 Err:
 34     WriteEXE = False
 35     Close #FileNum
 36 End Function
 37 
 38 
 39 Public Function GetInfo(FileName As String, infolen As Long) As String
 40 On Error GoTo Err
 41     Dim FileNum As Integer
 42     Dim Record As Long
 43     Dim tempstr As Byte
 44     Dim I As Long
 45     
 46     FileNum = FreeFile
 47     Open FileName For Binary Access Read As #FileNum
 48     For I = 0 To infolen - 1
 49         Record = LOF(FileNum) - infolen + I
 50         Get #FileNum, Record, tempstr
 51         If tempstr > 0 Then
 52           GetInfo = GetInfo & Chr(tempstr)
 53         End If
 54     Next I
 55 Err:
 56     GetInfo = Replace(GetInfo, Chr(0), "")
 57     GetInfo = Trim(GetInfo)
 58     Close #FileNum
 59 End Function
 60 
 61 
 62 Public Function GetCommand(strCmdLine As String, VarName As String) As String
 63 On Error Resume Next
 64 '取变量值   返回变量的值
 65 'strCmdLine 服务器返回的数据
 66 'varname    变量名
 67 If strCmdLine = "" Then Exit Function '参数必须存在
 68 Dim strCmd() As String, I%
 69     strCmd = Split(strCmdLine, "&")
 70     For I = 0 To UBound(strCmd)
 71         If Len(strCmd(I)) > Len(VarName) Then
 72             If LCase(Left(strCmd(I), Len(VarName))) = LCase(VarName) Then
 73                 GetCommand = Mid(strCmd(I), InStr(strCmd(I), "=") + 1)
 74             End If
 75         End If
 76     Next
 77 End Function
 78 
 79 
 80 Public Function Encdec(inputstrinG As String) As String
 81 Dim p As String, o As String, k As String, s As String, tempstr As String, I As Integer, g As Integer
 82    If Len(inputstrinG) = 0 Then Exit Function
 83    g = 1
 84    For I = 1 To Len(inputstrinG)
 85      p = Mid$(inputstrinG, I, 1)
 86      o = Asc(p)
 87      k = o Xor g
 88      s = Chr$(k)
 89      tempstr = tempstr & s
 90      If g = 255 Then g = 1 Else g = g + 1
 91    Next I
 92 Encdec = tempstr
 93 End Function
 94 
 95 
 96 '从资源文件中读出数据并另存为磁盘文件
 97 Public Sub resDataFile(Id, resType, FileName As String)
 98 Dim resFile() As Byte, FileNum As Integer
 99 On Error GoTo Err
100    resFile = LoadResData(Id, resType)
101    FileNum = FreeFile
102    Open FileName For Binary Access Write As #FileNum
103     Put #FileNum, , resFile
104    Close #FileNum
105 Exit Sub
106 Err:
107    MsgBox Err.Description & "：" & Err.Number, vbInformation, "错误"
108 End Sub
109 
110 Public Function GetDataForFile(FileName As String) As Byte()
111 On Error Resume Next
112     Dim DAT() As Byte, FileNum As Integer, FileSize As Long
113     FileNum = FreeFile
114     FileSize = FileLen(FileName)
115     ReDim DAT(FileSize - 1) As Byte
116     Open FileName For Binary As #FileNum
117       Get #FileNum, , DAT
118     Close
119     GetDataForFile = DAT
120 End Function
121 
122 Public Function 读取EXE内信息(FileName As String) As String
123 On Error Resume Next
124 '从EXE尾读信息
125 Dim base64 As New base64
126 Dim URL As String
127 Dim Strtem As String
128 Strtem = GetInfo(FileName, ExeInfoLen)
129 'Strtem = encdec(Strtem)
130 Strtem = base64.Decode(Strtem)
131 读取EXE内信息 = Strtem
132 'Dim 网址 As String, 备注 As String
133 '网址 = GetCommand(Strtem, "网址")
134 '备注 = GetCommand(Strtem, "备注")
135 Set base64 = Nothing
136 End Function
137 
138 Public Function 写信息到EXE内(FileName As String, infoStr As String) As Boolean
139 On Error Resume Next
140    Dim base64 As New base64
141    Dim Strtem As String
142 
143     Strtem = infoStr
144     Strtem = base64.Encode(Strtem)
145     'Strtem = encdec(Strtem)
146     Set base64 = Nothing
147     If Len(Strtem) > ExeInfoLen Then
148        MsgBox "信息过长", vbCritical, "错误"
149        Exit Function
150     End If
151    'WriteEXE LoadResData(101, "CUSTOM"), FileName, Strtem, ExeInfoLen    '从资源文件中提取EXE
152    WriteEXE GetDataForFile(FileName), FileName, Strtem, ExeInfoLen
153 End Function
154 Private Sub Command1_Click()
155 写信息到EXE内 App.Path & "\" & App.EXEName & ".exe", "username=abcd&password=1234&dns=sutuo.3322.org"
156 End Sub
157 
158 Private Sub Command2_Click()
159 dim Strtem as string 
160 Strtem= 读取EXE内信息(App.Path & "\" & App.EXEName & ".exe")
161 MsgBox GetCommand(Strtem, "username")
162 MsgBox GetCommand(Strtem, "password")
163 MsgBox GetCommand(Strtem, "dns")
164 End Sub
165