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
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
