用VB6写在线更新程序（中篇）

' 下载地址。
Private Const UPDATE_CONFIG_FILE = "http://solid-system/Apps/BCC/BCCUpdate.xml" ' 更新配置文件地址。

Private AppFile As String ' 当前程序执行文件名。
Private AppVer As String ' 当前程序版本号。
Private XmlConfig As XmlConfiguration

Private Sub Form_Load()
Label1.Caption = "正在启动程序..."

' 显示程序版本号。
AppFile = App.Path & "/" & App.EXEName & ".EXE"
AppVer = GetFileVersion(AppFile)
lblVersion.Caption = "版本：" & AppVer

' 装载XML更新配置。
Set XmlConfig = New XmlConfiguration
If InitXmlConfig(UPDATE_CONFIG_FILE) Then
Timer1.Enabled = True
Else
Unload Me ' 直接运行程序。
End If
End Sub

'{ 初始化配置处理对象，并装载配置文件。Cable Fan 2009-08-15 }
Private Function InitXmlConfig(ConfigUrl As String) As Boolean
On Error GoTo CATCH

If XmlConfig.Load(ConfigUrl) Then ' 装载配置信息。
InitXmlConfig = True
Else
MsgBox "装载XML配置文件：“" & ConfigUrl & "”失败！" & vbCrLf & err.Description
InitXmlConfig = False
End If

Exit Function
CATCH:
MsgBox "无法下载在线更新配置文件。" & vbCrLf & err.Description
InitXmlConfig = False
End Function

Private Sub Timer1_Timer()
If XmlConfig.Ready Then
'Label1.Caption = "等待配置加载完成..."
Timer1.Enabled = False
Label1.Caption = "正在处理更新配置..."

' 解析XML配置。
If XmlConfig.Analysis Then
Label1.Caption = "正在比较更新版本..."
Select Case CheckUpdate(AppVer)
Case -1
' 取消更新则退出程序。
End
Case 0
Label1.Caption = "正在验证当前数据库有效性连接..."
DBConnect
Label1.Caption = "当前数据库有效"

Unload Me
Case 1
' 需要更新，启动更新程序。
Dim CmdLine As String ' 执行更新程序的命令行。
CmdLine = App.Path & "/Update.exe"
If FileExists(CmdLine) Then
CmdLine = CmdLine & " """ & UPDATE_CONFIG_FILE & """ """ & App.Path & "/" _
& App.EXEName & ".exe"
Shell CmdLine,vbNormalFocus
End ' 启动更新程序后退出程序。
Else
MsgBox "更新程序不存在，请重新安装程序！"
End ' 退出程序。
End If
End Select
Else
Label1.Caption = "无法解析XML配置，直接启动旧程序！"
Unload Me
End If
End If
End Sub

'{ 检查在线更新，无需更新返回0，执行更新返回1，取消更新返回-1（将退出程序）。Cable Fan 2009-08-15 }
Private Function CheckUpdate(AppVer As String) As Integer
On Error GoTo CATCH

If CompareVersion(XmlConfig.Version,AppVer) > 0 Then
' 有可用更新。
Dim Msg As String '更新提示内容。
Msg = "您现在使用的版本是：" & AppVer & "，服务器上有可用的更新版本：" & XmlConfig.Version & "。"
If XmlConfig.Force Then
Msg = Msg & vbCrLf & "当前版本的程序已经不可用，您必须更新到新版本才能继续使用！"
Else
Msg = Msg & vbCrLf & "当前版本仍然可用，但建议你更新到新版本。"
End If

If MsgBox(Msg,vbQuestion + vbYesNo + vbDefaultButton1) = vbYes Then
CheckUpdate = 1 '执行更新。
Else
If XmlConfig.Force Then
CheckUpdate = -1 '取消了强制更新。
Else
CheckUpdate = 0 '取消了非强制更新。
End If
End If
Else
CheckUpdate = 0 ' 无需更新。
End If

Exit Function
CATCH:
MsgBox "无法检查程序版本。" & vbCrLf & err.Description
CheckUpdate = 0 ' 无法检查更新时允许跳过。
End Function

Option Explicit

' API函数声明
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias "GetFileVersionInfoA" ( ByVal lptstrFilename As String,ByVal dwhandle As Long,ByVal dwlen As
Long,lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" ( ByVal lptstrFilename As String,lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any,ByVal lpSubBlock As String,lplpBuffer As Any,puLen As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any,ByVal Source As Long,ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" ( ByVal lpString1 As String,ByVal lpString2 As Long) As Long
Public Declare Function WinExec Lib "kernel32" ( ByVal lpCmdLine As String,ByVal nCmdShow As Long) As Long
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( ByVal lpFileName As String,lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( ByVal hFindFile As Long,lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindClose Lib "kernel32" ( ByVal hFindFile As Long) As Long
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" ( ByVal lpExistingFileName As String,ByVal lpNewFileName As String,ByVal bFailIfExists As Long) As
Long
Public Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" ( ByVal lpPathName As String,lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" ( ByRef Ptr() As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any,Source As Any,ByVal Length As Long)
Public Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( ByRef saArray() As Any) As Long

Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXPLORER = &H80000 ' new look commdlg

Public Const MAX_PATH1 = 260
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10

Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH1
cAlternate As String * 14
End Type


' 文件信息结构。
Public Type FILEINFO
CompanyName As String
FileDescription As String
FileVersion As String
InternalName As String
LegalCopyright As String
OriginalFileName As String
ProductName As String
ProductVersion As String
End Type

Public Type FIXEDFILEINFO
dwSignature As Long ' e.g. $feef04bd
dwStrucVersion As Long ' e.g. $00000042 = "0.42"
dwFileVersionMS As Long ' e.g. $00030075 = "3.75"
dwFileVersionLS As Long ' e.g. $00000031 = "0.31"
dwProductVersionMS As Long ' e.g. $00030010 = "3.10"
dwProductVersionLS As Long ' e.g. $00000031 = "0.31"
dwFileFlagsMask As Long ' = $3F for version "0.42"
dwFileFlags As Long ' e.g. VFF_DEBUG | VFF_PRERELEASE
dwFileOS As Long ' e.g. VOS_DOS_WINDOWS16
dwFileType As Long ' e.g. VFT_DRIVER
dwFileSubtype As Long ' e.g. VFT2_DRV_KEYBOARD
dwFileDateMS As Long ' e.g. 0
dwFileDateLS As Long ' e.g. 0
End Type

' 获取文件信息函数返回值。
Public Enum VerisonReturnValue
eOK = 1
eNoVersion = 2
End Enum

'{ 强制创建路径中的每个文件夹(如果不存在)。Cable Fan 2009-08-18 }
Public Function ForceDirectories(Path As String) As Boolean
Dim P As String
P = Trim(Path)
If Right(P,1) = "/" Then P = Left(P,Len(P) - 1)

If P = "" Then
ForceDirectories = False
Exit Function
End If

Dim SA As SECURITY_ATTRIBUTES
If (Len(P) < 3) Or DirectoryExists(P) Or (ExtractFilePath(P) = P & "/") Then
ForceDirectories = True
Exit Function
End If

ForceDirectories = ForceDirectories(ExtractFilePath(P)) And CreateDirectory(P,SA)
End Function

'{ 检测指定的目录是否存在。Cable Fan 2009-08-18 }
Public Function DirectoryExists(Path As String) As Boolean
Dim Exists As Boolean

' 去除最后的分隔符。
Dim P As String
P = Path
If Right(P,1) = "/" Then P = Mid(P,1,Len(P) - 1)

Dim WFD As WIN32_FIND_DATA
Dim FHnd As Long
FHnd = FindFirstFile(P,WFD)

If FHnd = 0 Then
Exists = False ' 未找到配置的目录。
Else
If WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY > 0 Then '检找到的结果是否目录
Exists = True
Else
Exists = False
End If
FindClose FHnd
End If

DirectoryExists = Exists
End Function

' { 将指定文件名与指定路径合并得到完整文件名。Cable Fan 2009-08-18 }
Public Function GetFullFileName(Path As String,Short As String) As String
'{ 类似“C:/Folder1/Folder2/../../abc.txt”的文件名是有效的，所以本函数其实也是多余的。}

' 去除最后的分隔符。
Dim P As String
P = Path
If Right(P,Len(P) - 1)

' 将路径与文件名拆分到数组。
Dim Paths() As String,Files() As String
Paths = Split(P,"/"): Files = Split(Short,"/")

' 如果以盘符开头则直接返回。
If Mid(Short,2,1) = ":" Then
GetFullFileName = Short
Exit Function
End If

' 不含路径的文件名直接添加到路径后返回。
If UBound(Files) < 1 Then
GetFullFileName = P & "/" & Short
Exit Function
End If

Dim i As Integer
Dim j As Integer
Dim S As String,S1 As String ' 分别保存路径与文件名。

' 逐个比较路径中的每个文件夹
S = ""
S1 = ""
j = 0
For i = 0 To UBound(Files)
If Files(i) = ".." Then ' 退回路径
j = j + 1 ' 退回的路径数。
Else
S1 = S1 & "/" & Files(i) ' 添加文件中的路径及文件名。
End If
Next

' 组合未退回的路径。
If UBound(Paths) < j Then
S = "" ' 如果退回的路径超出了指定的路径则不添加路径。
Else
For i = 0 To UBound(Paths) - j
S = S & Paths(i) & "/"
Next
End If

' 去除路径最后的分隔符。
If Right(S,1) = "/" Then S = Left(S,Len(S) - 1)
GetFullFileName = S & S1
End Function

'{ 获取指定文件名相对于指定路径的短文件名。Cable Fan 2009-08-18 }
Public Function GetRelativeFileName(Path As String,FileName As String) As String
' 去除最后的分隔符。
Dim P As String
P = Path
If Right(P,"/"): Files = Split(FileName,"/")

' 不含路径的文件名直接返回。
If UBound(Files) < 1 Then
GetRelativeFileName = FileName
Exit Function
End If

Dim i As Integer
Dim j As Integer
Dim Diff As Boolean,Same As Boolean
Dim S As String

' 逐个比较路径中的每个文件夹
S = ""
Diff = False ' 尚未遇到不同路径。
Same = False ' 尚未遇到相同路径。
For i = 0 To UBound(Paths)
If i <= UBound(Files) - 1 Then ' 不计文件名
If UCase(Paths(i)) = UCase(Files(i)) Then
' 出现了相同路径且尚未出现不同路径。
If Not Diff Then Same = True
' 如果出现过不同路径并且，则出现的相同路径要退回（添加“../”）。
If Diff And Same Then S = "/.." & S

' 出现不同路径后直接将后面的路径添加到返回值，相同则忽略。
If Diff Then S = S & "/" & Files(i)
Else
Diff = True ' 到此处开始不相同。
' 如果已经出现过相同路径，则要将后面的路径退回（添加“../”）。
If Same Then S = "/.." & S
S = S & "/" & Files(i)
End If
Else
' 如果已经出现过相同路径，则要将后面的路径退回（添加“../”）。
If Same Then S = "/.." & S
End If
j = i
Next

' 将多出的路径添加到最后。
For i = j + 1 To UBound(Files) - 1 ' 不计文件名
S = S & "/" & Files(i)
Next

S = S & "/" & Files( UBound(Files)) ' 将文件名添加到最后。
If Left(S,1) = "/" Then S = Mid(S,Len(S)) ' 去除开头的分隔符。
GetRelativeFileName = S
End Function

'{ 获取指定文件的文件信息。Cable Fan 2009-08-04 }
Public Function GetFileInfo( ByRef pstrFieName As String,ByRef tFileInfo As FILEINFO) As VerisonReturnValue
Dim lBufferLen As Long,lDummy As Long
Dim sBuffer() As Byte
Dim lVerPointer As Long
Dim lRet As Long
Dim Lang_Charset_String As String
Dim HexNumber As Long
Dim i As Integer
Dim strTemp As String

'Clear the Buffer tFileInfo
tFileInfo.CompanyName = ""
tFileInfo.FileDescription = ""
tFileInfo.FileVersion = ""
tFileInfo.InternalName = ""
tFileInfo.LegalCopyright = ""
tFileInfo.OriginalFileName = ""
tFileInfo.ProductName = ""
tFileInfo.ProductVersion = ""
lBufferLen = GetFileVersionInfoSize(pstrFieName,lDummy)

If lBufferLen < 1 Then
GetFileInfo = eNoVersion
Exit Function
End If

ReDim sBuffer(lBufferLen)
lRet = GetFileVersionInfo(pstrFieName,0&,lBufferLen,sBuffer(0))
If lRet = 0 Then
GetFileInfo = eNoVersion
Exit Function
End If

lRet = VerQueryValue(sBuffer(0),"/VarFileInfo/Translation",lVerPointer,lBufferLen)
If lRet = 0 Then
GetFileInfo = eNoVersion
Exit Function
End If
Dim bytebuffer(255) As Byte
MoveMemory bytebuffer(0),lBufferLen
HexNumber = bytebuffer(2) + bytebuffer(3) * &H100 + bytebuffer(0) * &H10000 + bytebuffer(1) * &H1000000
Lang_Charset_String = Hex(HexNumber)


Do While Len(Lang_Charset_String) < 8
Lang_Charset_String = "0" & Lang_Charset_String
Loop

Dim strVersionInfo(7) As String
strVersionInfo(0) = "CompanyName"
strVersionInfo(1) = "FileDescription"
strVersionInfo(2) = "FileVersion"
strVersionInfo(3) = "InternalName"
strVersionInfo(4) = "LegalCopyright"
strVersionInfo(5) = "OriginalFileName"
strVersionInfo(6) = "ProductName"
strVersionInfo(7) = "ProductVersion"
Dim buffer As String


For i = 0 To 7
buffer = String(255,0)
strTemp = "/StringFileInfo/" & Lang_Charset_String & "/" & strVersionInfo(i)
lRet = VerQueryValue(sBuffer(0),strTemp,lBufferLen)

If lRet <> 0 Then
lstrcpy buffer,lVerPointer
buffer = Mid$(buffer,InStr(buffer,vbNullChar) - 1)
Select Case i
Case 0
tFileInfo.CompanyName = buffer
Case 1
tFileInfo.FileDescription = buffer
Case 2
tFileInfo.FileVersion = buffer
Case 3
tFileInfo.InternalName = buffer
Case 4
tFileInfo.LegalCopyright = buffer
Case 5
tFileInfo.OriginalFileName = buffer
Case 6
tFileInfo.ProductName = buffer
Case 7
tFileInfo.ProductVersion = buffer
End Select
End If
Next i

GetFileInfo = eOK
End Function

'{ 截取指定文件名中的短文件名(不含路径)。Cable Fan 2009-08-13 }
Public Function ExtractFileName(FileName As String) As String
Dim i As Integer
i = LastDelimiter("/",FileName)
If i <= 0 Then i = LastDelimiter("/",FileName)
ExtractFileName = Mid(FileName,i + 1,Len(FileName))
End Function

'{ 截取指定文件名中的路径。Cable Fan 2009-08-14 }
Public Function ExtractFilePath(FileName As String) As String
Dim i As Integer
i = LastDelimiter("/",FileName)
ExtractFilePath = Left(FileName,i)
End Function

'{ 获取指定分隔在指定字符串中最后出现的位置。Cable Fan 2009-08-13 }
Public Function LastDelimiter(Delimiters As String,S As String) As Integer
Dim i As Integer: Dim j As Integer
j = 0
For i = Len(S) To 1 Step -1
If Mid(S,i,Len(Delimiters)) = Delimiters Then
j = i
Exit For
End If
Next
LastDelimiter = j
End Function

'{ 判断指定的文件是否存在。Cable Fan 2009-08-14 }
Public Function FileExists(FileName As String) As Boolean
On Error Resume Next
Dim FSO As New FileSystemObject
FileExists = FSO.FileExists(FileName)
Set FSO = Nothing
End Function

'{ 获取指定文件的修改时间。Cable Fan 2009-08-14 }
Public Function GetFileModifiedDate(FileName As String) As Date
On Error GoTo CATCH
Dim FSO As New FileSystemObject
Dim F As File
Set F = FSO.GetFile(FileName)
If Not F Is Nothing Then
GetFileModifiedDate = F.DateLastModified
Exit Function
End If
CATCH:
GetFileModifiedDate = CDate(0) ' 默认返回0时间。
End Function

''{ 获取指定文件的版本号。Cable Fan 2009-08-14 }
'Public Function GetFileVersion(FileName As String) As String
' Dim udtFileInfo As FILEINFO
'
' On Error Resume Next
'
' If GetFileInfo(FileName,udtFileInfo) = eNoVersion Then
' GetFileVersion = "0.0.0.0"
' Else
' GetFileVersion = udtFileInfo.FileVersion
' End If
'End Function

'{ 获取指定文件的版本号。Cable Fan 2009-08-14 }
Public Function GetFileVersion(FileName As String) As String
Dim V1 As Long,V2 As Long,V3 As Long,V4 As Long
V1 = 0: V2 = 0: V3 = 0: V4 = 0

Dim VerInfoSize As Long,dummy As Long
VerInfoSize = GetFileVersionInfoSize(FileName,dummy)
If VerInfoSize > 0 Then
Dim VerInfo() As Byte
ReDim VerInfo(VerInfoSize)

If GetFileVersionInfo(FileName,VerInfoSize,VerInfo(0)) <> 0 Then
Dim VerValue(255) As Byte
Dim VerPointer As Long
Dim VerValueSize As Long

If VerQueryValue(VerInfo(0),"/",VerPointer,VerValueSize) <> 0 Then
MoveMemory VerValue(0),VerValueSize
V1 = VerValue(11) * 2 ^ 8 + VerValue(10)
V2 = VerValue(9) * 2 ^ 8 + VerValue(8)
V3 = VerValue(15) * 2 ^ 8 + VerValue(14)
V4 = VerValue(13) * 2 ^ 8 + VerValue(12)
End If
End If
End If

GetFileVersion = V1 & "." & V2 & "." & V3 & "." & V4
End Function

'{ 获取指定文件的产品版本号。Cable Fan 2009-08-14 }
Public Function GetProductVersion(FileName As String) As String
Dim udtFileInfo As FILEINFO

On Error Resume Next

If GetFileInfo(FileName,udtFileInfo) = eNoVersion Then
GetProductVersion = "0.0.0.0"
Else
GetProductVersion = udtFileInfo.ProductVersion
End If
End Function

'{ 将版本号拆分为主版本、次版本、发行版本与修订版本。Cable Fan 2009-08-14 }
Public Sub SplitVersion(AVersion As String,ByRef AMajor As Integer,ByRef AMinor As Integer,_
ByRef ARelease As Integer,ByRef ARevision As Integer)
Dim Ver() As String
Ver = Split(AVersion,".")
If UBound(Ver) >= 0 Then If IsNumeric(Ver(0)) Then AMajor = Ver(0)
If UBound(Ver) >= 1 Then If IsNumeric(Ver(1)) Then AMinor = Ver(1)
If UBound(Ver) >= 2 Then If IsNumeric(Ver(2)) Then ARelease = Ver(2)
If UBound(Ver) >= 3 Then If IsNumeric(Ver(3)) Then ARevision = Ver(3)
End Sub

'{ 比较两个指定的版本号的新旧，V1比V2新返回1,相等返回0,旧则返回-1。Cable Fan 2009-08-14}
Public Function CompareVersion(V1 As String,V2 As String) As Integer
Dim Result As Integer
Result = 0

' 拆分版本号。
Dim S1 As Integer: Dim S2 As Integer: Dim S3 As Integer: Dim S4 As Integer
Dim D1 As Integer: Dim D2 As Integer: Dim D3 As Integer: Dim D4 As Integer
SplitVersion V1,S1,S2,S3,S4
SplitVersion V2,D1,D2,D3,D4

' 比较主版本号。
If S1 > D1 Then
Result = 1
ElseIf S1 < D1 Then
Result = -1
Else
' 主版本号相等时继续比较次版本号。
If S2 > D2 Then
Result = 1
ElseIf S2 < D2 Then
Result = -1
Else
' 次要版本号也相等时继续比较发行版本号。
If S3 > D3 Then
Result = 1
ElseIf S3 < D3 Then
Result = -1
Else
' 发行版本号也相等则比较修订版本号。
If S4 > D4 Then
Result = 1
ElseIf S4 < D4 Then
Result = -1
Else
Result = 0 ' 最终相等。
End If
End If
End If
End If
CompareVersion = Result ' 返回比较结果。
End Function

'{ 检查指定版本号与当前程序版本号的新旧，指定的新返回1,指定的版本号旧则返回-1。}
Public Function CheckVersion(AMajor As Integer,AMinor As Integer,ARevision As Integer) As Integer
Dim Result As Integer
Result = 0

' 比较主版本号。
If AMajor > App.Major Then
Result = 1
ElseIf AMajor < App.Major Then
Result = -1
Else
' 主版本号相等时继续比较次版本号。
If AMinor > App.Minor Then
Result = 1
ElseIf AMinor < App.Minor Then
Result = -1
Else
' 次要版本号也相等时继续比较修订号。
If ARevision > App.Revision Then
Result = 1
ElseIf ARevision < App.Revision Then
Result = -1
Else
Result = 0 ' 最终相等。
End If
End If
End If
CheckVersion = Result ' 返回比较结果。
End Function