VERSION 5.00

Begin VB.Form frmMain

Caption = "請點擊升級進行程序"

ClientHeight = 1140

ClientLeft = 60

ClientTop = 345

ClientWidth = 4500

LinkTopic = "Form1"

ScaleHeight = 1140

ScaleWidth = 4500

StartUpPosition = 3 '窗口缺省

Begin VB.CommandButton Command1

Caption = "升級"

Height = 525

Left = 1380

TabIndex = 0

Top = 570

Width = 1245

End

End

Attribute VB_Name = "frmMain"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

option Explicit

' ------------------------------------------
' 升級程序的例子
' 作者: 謝家峰
' 日期: 2003/12/19
'
' 這里是沒有升級時的主程序
'
' ------------------------------------------

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

' 記錄運行狀態
WritePrivateProfileString "Main", "Active", "-1", UpdateIniPath

' 記錄更新次數
WritePrivateProfileString "Update", "Num", "0", UpdateIniPath
Me.Caption = App.EXEName
End Sub

Private Sub Form_Unload(Cancel As Integer)
' 記錄運行狀態
WritePrivateProfileString "Main", "Active", "0", UpdateIniPath
End Sub

用記事本打開modCommon.bas文件，copy以下內容到其中：

Attribute VB_Name = "modCommon"

Option Explicit

' ------------------------------------------
' 升級程序的例子
' 作者: 謝家峰
' 日期: 2003/12/19
'
' 這里是通用模塊，放置API函數以及公用函數
'
' ------------------------------------------

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

Const WM_Close = &H10
Private Const gintMAX_SIZE% = 255 'Maximum buffer size

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

End 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

' ===============================================
' 讀Ini文件
'
' ===============================================

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

VERSION 5.00
Begin VB.Form frmUpdate
BackColor = &H80000007&
BorderStyle = 0 'None
Caption = "Form1"
ClientHeight = 1185
ClientLeft = 0
ClientTop = 0
ClientWidth = 5400
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1185
ScaleWidth = 5400
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command1
Appearance = 0 'Flat
Caption = "關閉"
Height = 435
Left = 2130
TabIndex = 0
Top = 630
Visible = 0 'False
Width = 1245
End

Begin VB.Label lblCap
AutoSize = -1 'True
BackStyle = 0 'Transparent
BeginProperty Font
Name = "宋體"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 240
Left = 330
TabIndex = 1
Top = 150
Width = 120
End

Begin VB.Shape Shape1
BackColor = &H00C0FFFF&
BackStyle = 1 'Opaque
BorderColor = &H0000FF00&
Height = 1065
Left = 60
Top = 60
Width = 5265
End
End

Attribute VB_Name = "frmUpdate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

' ------------------------------------------
' 升級程序的例子
' 作者: 謝家峰
' 日期: 2003/12/19
'
' 這里是升級程序
'
' ------------------------------------------

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 & "mp.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
' 檢查主程序是否開啟，若開啟則關閉舊程序

MainState = CBool(CInt(ReadIniFile(UpdateIniPath, "Main", "Active", "0")))

If MainState Then

' 關閉舊程序
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

' 記錄主程序的名字

NewExeFile = NewExeFile & j
WritePrivateProfileString "Main", "Name", NewExeFile, UpdateIniPath
NewExeFile = App.Path & "" & NewExeFile & ".exe"

' 拷貝新程序

ChangeLabelPos Me, lblCap, "正在更新程序 ... "
Sleep 1000
FileCopy tmpFile, NewExeFile
Sleep 1000
' 刪除臨時程序
Kill tmpFile
' 記錄更新次數
WritePrivateProfileString "Update", "Num", CStr(i), UpdateIniPath
' 檢查舊程序的狀態
If MainState Then
ChangeLabelPos Me, lblCap, "正在啟動更新后的主程序 ... "
Sleep 1000
Shell NewExeFile, vbNormalNoFocus
End If
' 關閉更新程序
Command1.Visible = True
ChangeLabelPos Me, lblCap, "更新完成，請等待 3 秒后將自動關閉更新程序 ..."
Sleep 3000
lblCap.Refresh
Unload Me
End If
End Sub

Private Sub Form_Load()
If App.PrevInstance Then End
UpdateIniPath = App.Path & "Update.ini"
State = True
End Sub