Dim State As Boolean
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Activate()
Dim i As Integer
Dim j As String
Dim OldExeFile As String
Dim NewExeFile As String
Dim tmpFile As String
Dim MainState As Boolean
DoEvents
If State Then
' 获取旧主程序名称
OldExeFile = CStr(ReadIniFile(UpdateIniPath, "Main", "Name", "主程序"))
NewExeFile = OldExeFile
OldExeFile = App.Path & "\" & OldExeFile & ".exe"
tmpFile = App.Path & "\tmp.tmp"
' 改写升级次数
i = CInt(ReadIniFile(UpdateIniPath, "Update", "Num", "0"))
i = i + 1
ChangeLabelPos Me, lblCap, "这是您第" & i & "次升级!"
Sleep 1500
' 摸拟从网站下载新的更新程序。
ChangeLabelPos Me, lblCap, "正在 摸拟从网站下载新的升级程序 ..."
Sleep 1000
On Error Resume Next
Kill tmpFile
' 此处可以修改为将临时文件放在临时文件夹内
SaveFileFromRes 101, "CUSTOM", tmpFile
Sleep 1000
On Error GoTo 0
' 检查主程序是否开启,若开启则关闭旧程序
' 关闭旧程序
ChangeLabelPos Me, lblCap, "正在关闭旧程序 ... "
Sleep 300
' 这里强行关闭旧程序
' 你也可以发送消息,让旧程序自己关闭
Do While -1
DoEvents
If CloseValidForm(NewExeFile) Then
Exit Do
End If
Loop
Sleep 200
End If
' 删除旧程序
On Error Resume Next
ChangeLabelPos Me, lblCap, "正在删除旧程序 ... "
Sleep 1000
Kill OldExeFile
Sleep 1000
' 生成新主程序名称
' NewExeFile = CStr(ReadIniFile(UpdateIniPath, "Main", "Name", "主程序"))
j = Right(NewExeFile, 1)
If IsNumeric(j) Then
j = i
NewExeFile = Left(NewExeFile, Len(NewExeFile) - 1)
Else
j = 1
End If
b. 打开projNewMain.vbp,编译该工程,并且命名为“projNewMain.exe”;
c. 打开projUpdate.vbp,打开工具栏上的“vb资源编辑器”(若没找到,读者需要点击菜单“外接程序|外接程序管理器”,在打开的对话框中选择“vb6资源编辑器”,在加载行为中选择“加载/卸载”复选框),在资源编辑器中选择“添加自定义资源 …”,在打开的对话框中定位到Update文件夹,选择projNewMain.exe文件,保存该资源文件,最后编译该工程并且命名为“Update.exe”。
d. 将可执行文件“主程序.exe”、“Update.exe”拷贝到同一个文件夹中,运行任一个程序,相信读者会看到效果。
Private Sub Command1_Click()
Command1.Enabled = False
' 运行更新程序
Shell App.Path & "\update.exe", vbNormalFocus
End Sub
Private Sub Form_Load()
If App.PrevInstance Then End
UpdateIniPath = App.Path & "\Update.ini"
' 记录主程序的名字
WritePrivateProfileString "Main", "Name", App.EXEName, UpdateIniPath
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal lSize As Long, ByVal lpFilename As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As Any, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFilename As String) As Long
Public Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFilename As String) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public UpdateIniPath As String
' ===============================================
' 从资源文件中提取文件
'
' ===============================================
Public Function SaveFileFromRes(vntResourceID As Variant, sType As String, sFileName As String) As Boolean
Dim bytImage() As Byte
Dim iFileNum As Integer
On Error GoTo SaveFileFromRes_Err
SaveFileFromRes = True
bytImage = LoadResData(vntResourceID, sType)
iFileNum = FreeFile
Open sFileName For Binary As iFileNum
Put #iFileNum, , bytImage
Close iFileNum
Exit Function
SaveFileFromRes_Err:
SaveFileFromRes = False: Exit Function
Private Function StringFromBuffer(Buffer As String) As String
Dim nPos As Long
nPos = InStr(Buffer, vbNullChar)
If nPos > 0 Then
StringFromBuffer = Left$(Buffer, nPos - 1)
Else
StringFromBuffer = Buffer
End If
End Function
Public Function ReadIniFile(ByVal strIniFile As String, ByVal strSection As String, ByVal strKey As String, Optional ByVal strKeyDefault As String = vbNullString) As String
Dim strBuffer As String
strBuffer = Space$(gintMAX_SIZE)
If GetPrivateProfileString(strSection, strKey, strKeyDefault, strBuffer, gintMAX_SIZE, strIniFile) Then
ReadIniFile = StringFromBuffer(strBuffer)
End If
End Function
' 检查文件是否存在
Function FileExists(filename As String) As Boolean
On Error Resume Next
FileExists = (Dir$(filename) <> "")
End Function
' 改变标签的文本及位置
Public Function ChangeLabelPos(frm As Form, lbl As Label, msg As String)
With lbl
.Caption = msg
.Left = (frm.ScaleWidth - .Width) / 2
.Top = .Height / 2
End With
End Function
'关闭窗体
Function CloseValidForm(Ret As String) As Boolean
Dim WinWnd As Long
'搜寻该窗口的句柄
WinWnd = FindWindow(vbNullString, Ret)
If WinWnd <> 0 Then
SendMessage WinWnd, WM_Close, 0&, 0&
End If
CloseValidForm = True
End Function
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
Private Sub Form_Load()
'example by Matthew Gates (Puff0rz@hotmail.com)
DownloadFile "http://www.aaa.com/aa.ini", "c:\aa.ini"
End Sub
Option Explicit
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, sBuffer As Byte, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByVal sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const scUserAgent = "Tgwang"
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private mvarUrl As String
Private mvarSaveFile As String
Private mvarConnect As Boolean
Private hOpen As Long, hFile As Long
Private Buffer As String, BufLen As Long
Private RetQueryInfo As Boolean
Public Event GetData(Progress As Long) '下载进度
Public Event ErrMassage(Description As String) '错误信息
Public Event DownLoadOver()
Public Sub Execute()
If RetQueryInfo Then
Buffer = Mid$(Buffer, 1, BufLen)
Else
Buffer = ""
End If
End If
End If
End Sub
'Public Function FileSize() As Long
' FileSize = GetHeader("Content-Length")
'End Function
Public Function StartDownLoad() As Boolean
Dim sBuffer(1 To 1024) As Byte, Ret As Long
Dim intfile As Long, LBR As Long
Dim i As Long
If mvarConnect = False Then
Cancel
StartDownLoad = False
Exit Function
End If
On Error GoTo OutErr
Err.Clear
'If Dir$(mvarSaveFile) > " " Then
' Name mvarSaveFile As mvarSaveFile & ".bak"
'End If
If Len(Dir$(mvarSaveFile)) > 0 Then
If MsgBox("目标文件以存在是否覆盖!", vbInformation + vbYesNo, "提示") = vbNo Then
Cancel
StartDownLoad = False
Exit Function
End If
End If
intfile = FreeFile()
Open mvarSaveFile For Binary Access Write As #intfile
Do
InternetReadFile hFile, sBuffer(1), 1024, Ret
DoEvents
If Ret = 1024 Then
If mvarConnect = False Then
StartDownLoad = False
GoTo Quit
End If
Put #1, , sBuffer
Else
For i = 1 To Ret
Put #1, , sBuffer(i)
DoEvents
Next i
End If
LBR = LBR + Ret
RaiseEvent GetData(LBR)
DoEvents
Loop Until Ret < 1024
RaiseEvent DownLoadOver
Quit:
Close #intfile
'if Dir$(mvarSaveFile & ".bak") > " " Then
' Kill mvarSaveFile
' Name mvarSaveFile & ".bak" As mvarSaveFile
'End If
Cancel
Exit Function
OutErr:
Err.Clear
Cancel
Close #intfile
RaiseEvent ErrMassage("文件" & mvarSaveFile & "正在使用,无法进行操作")
On Error GoTo 0
Public Property Let SaveFile(ByVal FileName As String)
mvarSaveFile = FileName
End Property
Public Property Let URL(ByVal URL As String)
mvarUrl = URL
End Property
Public Function GetHeader(Optional hdrName As String) As String
Dim tmp As Long
Dim tmp2 As String
If mvarConnect = False Then
GetHeader = "0"
Cancel
Exit Function
End If
If Buffer <> "" Then
Select Case UCase$(hdrName)
Case "CONTENT-LENGTH"
tmp = InStr(Buffer, "Content-Length")
tmp2 = Mid$(Buffer, tmp + 16, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "CONTENT-TYPE"
tmp = InStr(Buffer, "Content-Type")
tmp2 = Mid$(Buffer, tmp + 14, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "DATE"
tmp = InStr(Buffer, "Date")
tmp2 = Mid$(Buffer, tmp + 6, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "LAST-MODIFIED"
tmp = InStr(Buffer, "Last-Modified")
tmp2 = Mid$(Buffer, tmp + 15, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case "SERVER"
tmp = InStr(Buffer, "Server")
tmp2 = Mid$(Buffer, tmp + 8, Len(Buffer))
tmp = InStr(tmp2, Chr$(0))
GetHeader = CStr(Mid$(tmp2, 1, tmp - 1))
Case vbNullString
GetHeader = Buffer
Case Else
GetHeader = "0"
End Select
Else
GetHeader = "0"
End If
End Function
Form1
Option Explicit
Dim WithEvents tg As DownLoad
Dim tmp As Long
Private Sub Form_Load()
Set tg = New DownLoad
T1 = "http://www.test.net/123.ini"
T2 = App.Path & "\123.ini"
Command1.Caption = "下载1"
Command3.Caption = "停止1"
End Sub
Private Sub tg_DownLoadOver()
MsgBox "下载成功!", vbInformation, "提示"
End Sub
Private Sub tg_ErrMassage(Description As String)
'错误信息
MsgBox Description, vbCritical, "错误"
End Sub
Private Sub tg_GetData(Progress As Long)
'Progress返回的是已下载的数据大小
L = Format$(Progress, "###,###") & "/" & Format$(tmp, "###,###")
End Sub
Private Sub Command3_Click()
tg.Cancel
End Sub
Private Sub Command1_Click()
Command1.Enabled = False
tg.URL = T1 '设置下载地址
tg.SaveFile = T2 '下载后的文件存放位置
tg.Execute '连接网络
tmp = CLng(tg.GetHeader("Content-Length")) '获取下载文件大小
tg.StartDownLoad '开始下载
Command1.Enabled = True
End Sub