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

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

「修改主程序入口」

在本篇中，主要对主程序的启动入口进行适当的修改，让其在启动时检测XML配置文件中的版本信息，提示版本更新，并启动更新程序下载更新（如果有可用更新）。

首先，在主窗体（这里不是主窗体，而是在启动屏）装载时，进行必要的初始化并装载XML配置：

' 下载地址。
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

这里需要一个Timer来等待XML的读取完成，这也是关键的代码了：

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

在Timer事件中，每一个步骤都显示一个提示信息，因为程序启动时通常都是显示一个启动屏的，而启动屏上显示一句提示，也好让用户知道程序在做什么呀。等到XML配置信息读取完毕（即XmlConfig.Ready为True）时，对XML配置信息进行解析（即XmlConfig.Analysis过程），使配置信息存储到XmlConfig的各个属性中去。

仅接着，通过CheckUpdate函数进行发布信息的比较，对返回的结果进行分别处理，共有3种情况：
      1)有更新，而且是强制更新时，用户主动取消了更新，这种情况下程序终止执行，直接退出；
      2)无更新时，程序不作提示继续执行。后面的DBConnect为数据库连接过程；
      3)有更新，且用户同意执行更新时，启动更新程序，然后终止执行主程序；当然，如果更新程序不存在是无法执行更新的，作出提示后同样终止执行主程序。

另外，在其它无法预测各种情况，致使无法正常检测更新配置时，允许直接运行旧程序。对于更新检测过程CheckUpdate，主要是拿当前发布的版本号与当前主程序的版本号进行比较，比较结果作出明了（让用户知道自己用的什么版本，当前发布了什么版本，是否强制更新，新版本作了什么修订等等）的提示。当然，更新提示应该做得更细致些，使用自定义对话框，将各个元素表现得更形象。在这里没有这样做，而是使用一个简单的消息框（偷了一下懒，呵呵）。

所有的代码就这么多了（嫌少了？后面还有…），对于Xmlconfiguration类的定义可以参考上篇。而其中用到的CompareVersion函数、FileExists函数等，都是一些比较独立的通用函数，一并写在一个名为FileCtrls.bas（盗用了Delphi的单元名，哈哈）模块里了。其实这些函数并没有什么技术含量，可是没办法，在Delphi里这些都是Borland的帅哥们写好的，在VB6里却要自己写。也不知道是不是我笨，或许有更好的实现方式呢，呜…

差点忘了，代码~

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, 1) = "/" Then P = Left(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, 1) = "/" Then P = Left(P, Len(P) - 1)

     ' 将路径与文件名拆分到数组。
     Dim Paths() As String, Files() As String
    Paths = Split(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, 2, 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), lVerPointer, 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, lVerPointer, lBufferLen)

         If lRet <> 0 Then
            lstrcpy buffer, lVerPointer
            buffer = Mid$(buffer, 1, 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, 0&, 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), VerPointer, 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,相等返回0,指定的版本号旧则返回-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