用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
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
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,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
原文链接：https://www.f2er.com/vb/262691.html' 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