呈上自写的自动更新类模块～
希望有高手能把它更加完善～
设计概念是～当执行档被执行时～
会去跑这个类比对Server上特定位置的档案～
如果发现有版本不同的情况～才会复制下来盖过～
因为不想另外写一支执行档来互Call～
所以必须得要执行档档名不同时功能才会生效～
以下示例是从我的一支小程式中抽取出来的一小段代码～
因为环环相扣，所以有些小地方会看得莫名其妙～
MainForm
程序代码：If CheckDomainName = True Then Call frmUpdata.CheckProgramVersion End If
frmUpdara
程序代码：
Option Explicit
Private WithEvents CompareVersion As ClsDtatCompare
Private Const ServerAddress = "???.???.???.???"
Private Const ServerPath = "\ABC"
Private Sub CompareVersion_SearchFileData(vData As String)
If vData <> "OK" Then
labUpdataResult.Caption = vData
DoEvents
Else
Unload Me
End If
End Sub
Private Sub CompareVersion_Updata(vData As Answer)
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Unload frmUpdata
Msg = "Do you want to Updata XILINX ?" '定義訊息。
Style = vbYesNo + vbInformation + vbDefaultButton2 '定義按鈕。
Title = "有新的更新檔案" '定義標題。
Help = "DEMO.HLP" '定義說明檔。
Ctxt = 1000 '定義內容代碼。
If vData = Whether Then
Response = MsgBox(Msg, Style, Title, Help, Ctxt) '顯示訊息。
If Response = vbYes Then '若使用者按下 [是]。
CompareVersion.UpAllData = Yes '產生相對回應。
ElseIf Response = vbNo Then '若使用者按下 [否]。
CompareVersion.UpAllData = No '產生相對回應。
Set CompareVersion = Nothing
End If
End If
End Sub
Private Sub Form_Load()
With labUpdataResult
.Top = 0
.Left = 0
.Height = frmUpdata.Height
.Width = frmUpdata.Width
.Caption = "程式版本檢查中 ..."
End With
' With frmUpdata
' .Top = labUpdataResult.Top
' .Left = labUpdataResult.Left
' .Height = labUpdataResult.Height
' .Width = labUpdataResult.Width
' End With
End Sub
Public Sub CheckProgramVersion()
Dim ServerPath As String
Dim Status As String
Set CompareVersion = New ClsDtatCompare
ServerPath = "\\" & ServerAddress & "ServerPath"
If IsFileExist(App.Path & "\Version.txt") = False Then Call WriteInfo(frmAbout)
With CompareVersion
.Filter = "*.*"
.LocalPath = App.Path
.TargetPath = IIf(IsFolderExist(ServerPath) = True, ServerPath, App.Path)
If UCase(Trim$(.TargetPath)) <> UCase(Trim$(.LocalPath)) Then
Status = IIf(.StartCopmare = True, "Updated Successfully !", "Updated Failure or Not updated !")
frmUpdata.labUpdataResult.Caption = Status
End If
End With
Set CompareVersion = Nothing
End Sub
Class
程序代码：
'自动更新类别
Option Explicit
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Const MaxLFNPath = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 * MaxLFNPath
cShortFileName As String * 14
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Dim WFD As WIN32_FIND_DATA
Dim bgndir$, curpath$, schpattern$, aa$, fname$, progdisk$
Dim hItem&, hFile&, rtn&, i%, j%, k%, tfiles&, tfsize#, stopyn As Boolean 'Boolean 數據類型 (Visual Basic)存放只可能為 True 或 False 的值
Dim X1&, buff$
'Dim x1& 是Dim x1 As Long「長整型」& 是 As Long的縮寫,! 是 as single 的縮寫,例如:dim x0!,x1!,t!(或：dim x0 as single,x1 as single,t as single)
Public Enum Answer
Whether = 0
Yes
No
End Enum
Private Type FileStruct
FullFileStation As String
FileName As String
FilePath As String
FileSize As Long
FilesStatus As WIN32_FIND_DATA
FCreationTime As String
FLastAccessTime As String
FLastWriteTime As String
End Type
Private Type ServerFileList
S_FileList() As FileStruct
S_EXE_Ver As String
S_EXE_Name As String
S_FL_Count As Integer
End Type
Private Type LocalFileList
L_FileList() As FileStruct
L_EXE_Ver As String
L_EXE_Name As String
L_FL_Count As Integer
End Type
Private Type UpDataFileList
U_FileList() As FileStruct
U_EXE_Ver As String
U_EXE_Name As String
U_FL_Count As Integer
End Type
Private Type CompareFile_INFO
LocalPath As String
FileFilter As String
ServerPath As String
L_FileINFO As LocalFileList
S_FileINFO As ServerFileList
U_FileINFO As UpDataFileList
UserAnswer As Answer
End Type
Private CompFile() As CompareFile_INFO
'Class事件--------------------------------------------------------------
Public Event DataBack(vData As String, vData1() As String) '更新資料
Public Event Updata(vData As Answer) '是否更新
Public Event SearchFileData(vData As String) '搜尋過程
Public Property Let UpAllData(ByVal vData As Answer)
CompFile(0).UserAnswer = vData
If CompFile(0).UserAnswer = Yes Then
Call DownLoadFiles
End If
End Property
Private Sub Class_Initialize()
ReDim CompFile(0)
End Sub
Private Sub Class_Terminate()
Erase CompFile
End Sub
Public Property Let TargetPath(ByVal vData As String)
CompFile(0).ServerPath = vData
End Property
Public Property Get TargetPath() As String
TargetPath = CompFile(0).ServerPath
End Property
Public Property Let Filter(ByVal vData As String)
CompFile(0).FileFilter = vData
End Property
Public Property Let LocalPath(ByVal vData As String)
CompFile(0).LocalPath = vData
End Property
Public Property Get LocalPath() As String
LocalPath = CompFile(0).LocalPath
End Property
Public Function StartCopmare() As Boolean
StartCopmare = SearchFile
End Function
Public Function StartUpdata() As Boolean
StartUpdata = SearchFile
End Function
Private Function SearchFile() As Boolean
Dim s As String, i As Integer
Dim L_Ver As String, S_Ver As String, L_Temp() As String, S_Temp() As String, U_Temp() As String
Dim CompResult As Boolean
CompResult = False
With CompFile(0)
For i = 0 To 1
If .FileFilter = "" Then .FileFilter = "*.*"
If i = 0 Then s = Trim(.LocalPath)
If i = 1 Then s = Trim(.ServerPath)
bgndir = s '開始搜的文件夾
If InStr(bgndir, ":") = 0 And Len(bgndir) = 1 Then bgndir = bgndir & ":"
If Right(bgndir, 1) <> "\" Then bgndir = bgndir & "\"
schpattern = Trim(.FileFilter) '模糊搜索條件,例如 *.* 或 *.mp3 或 sc*.*
Call SearchDirs(bgndir, i)
Next i
SearchFile = True
.L_FileINFO.L_EXE_Name = UCase(Trim(App.EXEName) & App.Major & "." & App.Minor & "." & App.Revision & ".0" & ".exe")
.S_FileINFO.S_EXE_Name = UCase(Trim(.S_FileINFO.S_EXE_Name))
.L_FileINFO.L_EXE_Ver = Mid$(.L_FileINFO.L_EXE_Name, InStrRev(.L_FileINFO.L_EXE_Name, "V") + 1, InStrRev(.L_FileINFO.L_EXE_Name, "V") - Len(".EXE") - 1)
.S_FileINFO.S_EXE_Ver = Mid$(.S_FileINFO.S_EXE_Name, InStrRev(.S_FileINFO.S_EXE_Name, "V") + 1, InStrRev(.S_FileINFO.S_EXE_Name, "V") - Len(".EXE") - 1)
If .L_FileINFO.L_EXE_Name = .S_FileINFO.S_EXE_Name Or .L_FileINFO.L_EXE_Ver = .S_FileINFO.S_EXE_Ver Then
RaiseEvent SearchFileData("OK")
Else
If .L_FileINFO.L_EXE_Ver <> .S_FileINFO.S_EXE_Ver Then
If InStr(.L_FileINFO.L_EXE_Ver, ".") <> 0 And InStr(.S_FileINFO.S_EXE_Ver, ".") <> 0 Then
L_Temp = Split(.L_FileINFO.L_EXE_Ver, "."): S_Temp = Split(.S_FileINFO.S_EXE_Ver, ".")
If UBound(L_Temp) = UBound(S_Temp) Then
For i = 0 To UBound(L_Temp)
If Val(L_Temp(i)) = Val(S_Temp(i)) Then
CompResult = False
ElseIf Val(L_Temp(i)) < Val(S_Temp(i)) Then
CompResult = True
Exit For
End If
Next i
End If
If CompResult = True Then
Call All_DataCompare
RaiseEvent Updata(Whether)
Else
RaiseEvent DataBack("本地端程式版本較新，故不更新。", U_Temp())
End If
End If
End If
End If
End With
' If tfiles > 0 Then
' MsgBox "搜索完成,共查找到" & str(tfiles) & " 個文件" & vbCrLf & Chr(10) & "總佔空間: " & Format(str(tfsize), "#,###") & " Bytes"
' Else
' MsgBox "搜索完成,未找到符合的文件"
' End If
End Function
Private Sub SearchDirs(curpath, i As Integer)
Dim dirs%, dircount%, dirbuf$()
On Error Resume Next
RaiseEvent SearchFileData("正在查找 " & curpath)
DoEvents
hItem = FindFirstFile(curpath & "*", WFD)
If hItem <> INVALID_HANDLE_VALUE Then
Do
DoEvents
If stopyn Then Exit Do
If (WFD.dwFileAttributes And vbDirectory) And Asc(WFD.cFileName) <> 46 Then
If (dirs Mod 10) = 0 Then ReDim Preserve dirbuf(dirs + 10)
dirs = dirs + 1
dirbuf(dirs) = Left(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
End If
Loop While FindNextFile(hItem, WFD)
Call FindClose(hItem)
Call mohusearch(curpath, i)
End If
For dircount = 1 To dirs
DoEvents
If stopyn Then Exit For
SearchDirs curpath & dirbuf$(dircount) & "\", i
Next dircount
End Sub
Private Sub mohusearch(curpath, index As Integer)
Dim TempString As String
On Error Resume Next
hFile = FindFirstFile(curpath & schpattern, WFD)
If hFile <> INVALID_HANDLE_VALUE Then
Do
DoEvents
If stopyn Then Exit Do
aa = Trim(Trim(curpath) & Trim(WFD.cFileName))
If (WFD.dwFileAttributes And vbDirectory) Or Asc(WFD.cFileName) = 46 Then
Else
k = InStr(aa, Chr(0))
If k > 0 Then
fname = Mid(aa, 1, k - 1)
aa = Trim(fname) ' & "," & Format(str(FileLen(fname)), "####") & " Bytes"
tfiles = tfiles + 1
tfsize = tfsize + FileLen(fname)
TempString = ""
If index = 0 Then
With CompFile(0).L_FileINFO
ReDim Preserve .L_FileList(.L_FL_Count)
.L_FileList(.L_FL_Count).FullFileStation = aa
Call UpFilesStatus(.L_FileList(.L_FL_Count))
TempString = .L_FileList(.L_FL_Count).FullFileStation
.L_FileList(.L_FL_Count).FileName = Mid$(TempString, InStrRev(TempString, "\") + 1)
.L_FileList(.L_FL_Count).FileSize = FileLen(TempString)
.L_FileList(.L_FL_Count).FilePath = Mid$(TempString, 1, InStrRev(TempString, "\"))
If Right$(UCase(Trim(TempString)), 4) = UCase$(".EXE") Then
.L_EXE_Name = Trim(Mid$(TempString, InStrRev(TempString, "\") + 1))
End If
.L_FL_Count = .L_FL_Count + 1
End With
ElseIf index = 1 Then
With CompFile(0).S_FileINFO
ReDim Preserve .S_FileList(.S_FL_Count)
.S_FileList(.S_FL_Count).FullFileStation = aa
Call UpFilesStatus(.S_FileList(.S_FL_Count))
TempString = .S_FileList(.S_FL_Count).FullFileStation
.S_FileList(.S_FL_Count).FileName = Mid$(TempString, InStrRev(TempString, "\") + 1)
.S_FileList(.S_FL_Count).FileSize = FileLen(TempString)
.S_FileList(.S_FL_Count).FilePath = Mid$(TempString, 1, InStrRev(TempString, "\"))
If Right$(UCase(Trim(TempString)), 4) = UCase$(".EXE") Then
.S_EXE_Name = Trim(Mid$(TempString, InStrRev(TempString, "\") + 1))
End If
.S_FL_Count = .S_FL_Count + 1
End With
End If
TempString = ""
End If
End If
Loop While FindNextFile(hFile, WFD)
Call FindClose(hFile)
End If
End Sub
Private Function Findfile(xstrfilename) As WIN32_FIND_DATA
Dim Win32Data As WIN32_FIND_DATA
Dim plngFirstFileHwnd As Long
Dim plngRtn As Long
plngFirstFileHwnd = FindFirstFile(xstrfilename, Win32Data)
If plngFirstFileHwnd = 0 Then
Findfile.cFileName = "Error"
Else
Findfile = Win32Data
End If
plngRtn = FindClose(plngFirstFileHwnd)
End Function
Private Sub UpFilesStatus(FilesStuct As FileStruct)
Dim ftime As SYSTEMTIME
Dim tfilename As String
Dim filedata As WIN32_FIND_DATA
With FilesStuct
tfilename = .FullFileStation
filedata = Findfile(tfilename)
.FilesStatus.cFileName = WFD.cFileName
'
If filedata.nFileSizeHigh = 0 Then
.FilesStatus.nFileSizeHigh = filedata.nFileSizeLow ' & " Bytes"
Else
.FilesStatus.nFileSizeLow = filedata.nFileSizeHigh ' & "Bytes"
End If
'
Call FileTimeToSystemTime(filedata.ftCreationTime, ftime)
.FilesStatus.ftCreationTime = WFD.ftCreationTime
.FCreationTime = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear & " " & ftime.wHour & ":" & ftime.wMinute & ":" & ftime.wSecond
Call FileTimeToSystemTime(filedata.ftLastWriteTime, ftime)
.FilesStatus.ftLastWriteTime = WFD.ftLastWriteTime
.FLastWriteTime = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear & " " & ftime.wHour & ":" & ftime.wMinute & ":" & ftime.wSecond
Call FileTimeToSystemTime(filedata.ftLastAccessTime, ftime)
.FilesStatus.ftLastAccessTime = WFD.ftLastAccessTime
.FLastAccessTime = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear
'以下保留(暫無用處)
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_HIDDEN) = FILE_ATTRIBUTE_HIDDEN Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_HIDDEN
Else
.FilesStatus.dwFileAttributes = 0
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_SYSTEM) = FILE_ATTRIBUTE_SYSTEM Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_SYSTEM
Else
.FilesStatus.dwFileAttributes = 0
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_READONLY
Else
.FilesStatus.dwFileAttributes = 0
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_ARCHIVE) = FILE_ATTRIBUTE_ARCHIVE Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_ARCHIVE
Else
.FilesStatus.dwFileAttributes = 0
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_TEMPORARY) = FILE_ATTRIBUTE_TEMPORARY Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_TEMPORARY
Else
.FilesStatus.dwFileAttributes = 0
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_NORMAL) = FILE_ATTRIBUTE_NORMAL Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_NORMAL
Else
.FilesStatus.dwFileAttributes = 0
End If
If (filedata.dwFileAttributes And FILE_ATTRIBUTE_COMPRESSED) = FILE_ATTRIBUTE_COMPRESSED Then
.FilesStatus.dwFileAttributes = FILE_ATTRIBUTE_COMPRESSED
Else
.FilesStatus.dwFileAttributes = 0
End If
End With
End Sub
Private Sub All_DataCompare()
Dim i As Integer, j As Integer
Dim S_Temp As String, L_Temp As String
With CompFile(0)
For i = 0 To UBound(.S_FileINFO.S_FileList)
S_Temp = .S_FileINFO.S_FileList(i).FileName
For j = 0 To UBound(.L_FileINFO.L_FileList)
L_Temp = .L_FileINFO.L_FileList(j).FileName
If S_Temp = L_Temp Or (S_Temp <> L_Temp And Right(S_Temp, 4) = Right(L_Temp, 4) And Right(UCase(Trim(S_Temp)), 4) = ".EXE") Then
If .S_FileINFO.S_FileList(i).FileSize <> .L_FileINFO.L_FileList(j).FileSize Then
ReDim Preserve .U_FileINFO.U_FileList(.U_FileINFO.U_FL_Count)
If Right$(UCase$(Trim$(.S_FileINFO.S_EXE_Name)), 3) = "EXE" Then
.U_FileINFO.U_EXE_Name = .S_FileINFO.S_EXE_Name
.U_FileINFO.U_EXE_Ver = .S_FileINFO.S_EXE_Ver
End If
With .U_FileINFO.U_FileList(.U_FileINFO.U_FL_Count)
.FileName = S_Temp
.FilePath = CompFile(0).S_FileINFO.S_FileList(i).FilePath & "," & CompFile(0).L_FileINFO.L_FileList(j).FilePath
.FileSize = CompFile(0).S_FileINFO.S_FileList(i).FileSize
.FLastAccessTime = CompFile(0).S_FileINFO.S_FileList(i).FLastAccessTime
.FCreationTime = CompFile(0).S_FileINFO.S_FileList(i).FCreationTime
.FLastWriteTime = CompFile(0).S_FileINFO.S_FileList(i).FLastWriteTime
End With
.U_FileINFO.U_FL_Count = .U_FileINFO.U_FL_Count + 1
Else
L_Temp = ""
End If
Exit For
End If
Next j
S_Temp = "": L_Temp = ""
Next i
End With
End Sub
Private Sub DownLoadFiles()
Dim i As Integer
Dim SName As String, SPath As String, LPath As String
With CompFile(0)
For i = 0 To .U_FileINFO.U_FL_Count - 1
SName = .U_FileINFO.U_FileList(i).FileName
SPath = Trim(Mid$(.U_FileINFO.U_FileList(i).FilePath, 1, InStr(.U_FileINFO.U_FileList(i).FilePath, ",") - 1))
LPath = Trim(Mid$(.U_FileINFO.U_FileList(i).FilePath, InStrRev(.U_FileINFO.U_FileList(i).FilePath, ",") + 1))
FileCopy SPath & SName, LPath & SName
SName = "": SPath = "": LPath = ""
Next i
End With
End Sub
