钢铁雄心3部队搭配:简单的局域网自动更新程序1

'能够在局域网中自动更新指定文件，本身也可以自动升级。对测试时的程序很有用。

'Main.bas

Option Explicit
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 CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

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

Private Type FILETIME
     LowDateTime            As Long
     HighDateTime           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 * 260    'MUST be set to 260
     cAlternate             As String * 14
End Type

Private Const CUR_FILE As String = "."
Private Const ALL_FILE As String = "*"

Sub Main()
      Dim i As Integer
      Dim j As Integer
      Dim strCmd As String
      Dim strServer As String
      Dim strRmFile() As String
      Dim strLcFile() As String
      Dim strExFile() As String
      On Error GoTo Err_Proc

      strCmd = Command()
      If strCmd = "" Then
          If Dir(App.Path & "\" & App.EXEName & ".cfg") <> "" Then
              strCmd = "-f " & App.Path & "\" & App.EXEName & ".cfg"
          Else
              'Frm_Updater.Show vbModal
              strCmd = "-f " & App.Path & "\" & App.EXEName & ".cfg"
          End If
      End If
      If Not ParseCmdLine(strCmd, strServer, strRmFile, strLcFile, strExFile) Then Exit Sub
      If Right(strServer, 1) <> "\" Then strServer = strServer & "\"
      CheckUpdate strServer, False 'updateself
      j = IIf(UBound(strRmFile) > UBound(strLcFile), UBound(strLcFile), UBound(strRmFile))
      For i = LBound(strRmFile) To j
          If FileLater(strServer & strRmFile(i), strLcFile(i)) = 1 Or Dir(strLcFile(i)) = "" Then
              UpdateFile 4, strServer, strRmFile(i), strLcFile(i)
          End If
      Next i
      DoEvents

      If (strExFile(LBound(strExFile)) = CUR_FILE) Then
          If Dir(strLcFile(LBound(strLcFile))) <> "" Then Shell strLcFile(LBound(strLcFile)), vbNormalFocus
      ElseIf (strExFile(LBound(strExFile)) = ALL_FILE) Then
          For i = LBound(strLcFile) To UBound(strLcFile)
              If Dir(strLcFile(i)) <> "" Then Shell strLcFile(i), vbNormalFocus
          Next i
      Else
          For i = LBound(strExFile) To UBound(strExFile)
              If Dir(strExFile(i)) <> "" Then Shell strExFile(i), vbNormalFocus
          Next i
      End If
      Exit Sub
Err_Proc:
      MsgBox "Main: " & Err.Description, vbCritical
End Sub
'处理命令行
Private Function ParseCmdLine(strCmd As String, strServer As String, strRFile() As String, strLFile() As String, strEFile() As String) As Boolean
      Dim CmdLine() As String
      Dim strCmdLine As String
      Dim strRmFiles As String
      Dim strLcFiles As String
      Dim strExFiles As String
      Dim strFlag As String
      Dim iCount As Integer
      Dim i As Integer
      strCmdLine = Trim(LCase(strCmd))
      ParseCmdLine = False
      If InStr(strCmdLine, Space(1)) < 1 Then Exit Function
      If InStr(strCmdLine, "-") < 1 And InStr(strCmd, "/") < 1 Then Exit Function
    
      If InStr(strCmdLine, "-f ") > 0 Or InStr(strCmdLine, "/f ") > 0 Then
          strLcFiles = Mid(strCmdLine, InStr(strCmdLine, " ") + 1)
          If Dir(strLcFiles) = "" Then Exit Function
          Open strLcFiles For Input As #1
          Line Input #1, strCmdLine
          Close #1
      End If
    
      strCmdLine = Replace(strCmdLine, """", "")
      strCmdLine = Trim(LCase(strCmdLine))
      If (InStr(strCmdLine, Space(1)) < 1) Then Exit Function
      If InStr(strCmdLine, "-") < 1 And InStr(strCmd, "/") < 1 Then Exit Function
      CmdLine = Split(strCmdLine, Space(1))
      iCount = UBound(CmdLine) - LBound(CmdLine) + 1
      If (iCount < 1) Then Exit Function
      strRmFiles = ""
      strLcFiles = ""
      strExFiles = ""
      For i = LBound(CmdLine) To UBound(CmdLine)
          Select Case CmdLine(i)
              Case "-s", "/s": 'server
                  i = i + 1
                  strServer = CmdLine(i)
              Case "-l", "/l", "-r", "/r", "-e", "/e": 'localfiles & remotefiles
                  strFlag = CmdLine(i)
                  i = i + 1
              Case Else
               
          End Select
          Select Case strFlag
              Case "-l", "/l":
                  strLcFiles = strLcFiles & Space(1) & CmdLine(i)
              Case "-r", "/r":
                  strRmFiles = strRmFiles & Space(1) & CmdLine(i)
              Case "-e", "/e":
                  strExFiles = strExFiles & Space(1) & CmdLine(i)
              Case Else
            
          End Select
      Next i
      If strLcFiles <> "" Then
          strLcFiles = Replace(strLcFiles, Space(1) & App.Path & "\" & App.EXEName & ".exe", "")
          strLcFiles = Replace(strLcFiles, Space(1) & App.EXEName & ".exe", "")
          strLFile = Split(Trim(strLcFiles), Space(1))
      End If
      If strRmFiles <> "" Then strRFile = Split(Trim(strRmFiles), Space(1))
      If strExFiles <> "" Then strEFile = Split(Trim(strExFiles), Space(1))
      ParseCmdLine = (strLcFiles <> "" Or strRmFiles <> "" Or strExFiles <> "")
      Exit Function
Err_Proc:
      ParseCmdLine = False
      MsgBox "ParseCmdLine: " & Err.Description, vbCritical
End Function
'更新文件
Private Function UpdateFile(iType As Integer, ParamArray Params() As Variant) As Boolean
      On Error GoTo Err_Proc
      UpdateFile = False
      Select Case iType
          Case 1: 'http下载
          Case 2: 'ftp下载
          Case 3: '
          Case 4: '局域网共享或者同机,params(0)=server,params(1)=serverfile,params(2)=localfile
              If (UBound(Params) > 1) Then
                  CreateFolder Mid(Params(2), 1, InStrRev(Params(2), "\"))
                  FileCopy Params(0) & Params(1), Params(2)
              End If
          Case Else '其它
      End Select
      UpdateFile = True
      Exit Function
Err_Proc:
      UpdateFile = False
      MsgBox "UpdateFile: " & Err.Description, vbCritical
End Function
Private Function CreateFolder(strPath As String) As Long
      Dim strP As String
      Dim Attrib As SECURITY_ATTRIBUTES
      strP = strPath
      If (Right(strP, 1) <> "\") Then strP = strP & "\"
      Attrib.nLength = LenB(Attrib)
      Attrib.bInheritHandle = False
      Attrib.lpSecurityDescriptor = &H0
      CreateFolder = CreateDirectory(strPath, Attrib)
End Function
'如果strFile2比strFile1新,返回2,strFile1比strFile2新,返回1,其它返回0
Private Function FileLater(strFile1 As String, strFile2 As String) As Integer
      Dim Win32Data1 As WIN32_FIND_DATA
      Dim Win32Data2 As WIN32_FIND_DATA
      Dim lHwnd As Long
    
      On Error GoTo Err_Proc
    
    
      FileLater = 0
      If (Dir(strFile1) = "") Or (Dir(strFile2) = "") Then Exit Function
      lHwnd = FindFirstFile(strFile1, Win32Data1)
      If lHwnd = 0 Then Exit Function
      FindClose (lHwnd)
      lHwnd = FindFirstFile(strFile2, Win32Data2)
      If lHwnd = 0 Then Exit Function
      FindClose (lHwnd)
    
      If Win32Data2.ftLastWriteTime.HighDateTime > Win32Data1.ftLastWriteTime.HighDateTime Then FileLater = 2: Exit Function
      If Win32Data2.ftLastWriteTime.HighDateTime < Win32Data1.ftLastWriteTime.HighDateTime Then FileLater = 1: Exit Function
      If Win32Data2.ftLastWriteTime.LowDateTime < 0 And Win32Data1.ftLastWriteTime.LowDateTime > 0 Then FileLater = 2: Exit Function
      If Win32Data2.ftLastWriteTime.LowDateTime > 0 And Win32Data1.ftLastWriteTime.LowDateTime < 0 Then FileLater = 1: Exit Function
      If Win32Data2.ftLastWriteTime.LowDateTime >= Win32Data1.ftLastWriteTime.LowDateTime Then FileLater = 2: Exit Function
      FileLater = 1
      Exit Function
Err_Proc:
      FileLater = 0
      MsgBox "FileLater: " & Err.Description, vbCritical
End Function

Private Function CheckUpdate(strServer As String, Optional ByVal bEcho As Boolean = True) As Boolean
    
      Dim strRmFile As String
      Dim strLcFile As String
    
      On Error GoTo Err_Proc
    
      CheckUpdate = False
      If strServer = "" Then Exit Function
      If Right(strServer, 1) <> "\" Then strServer = strServer & "\"
      strRmFile = strServer & "Updater.exe"
      strLcFile = App.Path & "\" & App.EXEName & ".exe"
      If FileLater(strRmFile, strLcFile) = 1 Then
          If (bEcho) Then
              If vbYes = MsgBox("A new version of [" & App.EXEName & "] was found at server: " & vbCrLf & strServer & _
                      vbCrLf & " Do u want to update?" & vbCrLf & "Note: " & App.EXEName & " will be closed when updating!", _
                                  vbExclamation + vbYesNo + vbDefaultButton2, "Update") Then
                  Open App.Path & "\Update.bat" For Output As #1
                  Print #1, "@echo off"
                  Print #1, "echo *** This will update " & App.EXEName & " to the latest version."
                  Print #1, "echo *** Note: " & App.EXEName & " will be executed after updating. Press Ctrl+C to cancel,or" & Chr(7)
                  Print #1, "pause"
                  Print #1, "copy /Y """ & strRmFile & """ """ & strLcFile & """"
                  Print #1, "start " & Replace(strLcFile, Space(1), """" & Space(1) & """")
                  Print #1, "del %0"
                  Close #1
                  Shell App.Path & "\Update.bat", vbNormalFocus
                  End
              End If
          Else
              Open App.Path & "\Update.bat" For Output As #1
              Print #1, "@echo off"
              Print #1, "copy /Y """ & strRmFile & """ """ & strLcFile & """"
              Print #1, "start " & Replace(strLcFile, Space(1), """" & Space(1) & """")
              Print #1, "del %0"
              Close #1
              Shell App.Path & "\Update.bat", vbHide
              End
          End If
      End If
      CheckUpdate = True
      Exit Function
Err_Proc:
      CheckUpdate = False
      MsgBox Err.Description, vbCritical
End Function