ACCESS自動更新模式

一、定義創建快捷方式過程：
Sub CreateTSCut(AppFullName As String)
Dim lnkPath As String, lnkName As String, ExePath As String, Ts As String
Dim i As Integer
 
  lnkName = "TSAPP"
  lnkPath = GetDirs("desktop") & "\"
  ExePath = CStr(SysCmd(acSysCmdAccessDir)) & "MSAccess.EXE"
 
  Open lnkPath & "tmp.vbs" For Output As #1
      Print #1, "Dim WSHShell,oShellLink"
      Print #1, "Set WSHShell = WScript.CreateObject(" & Chr(34) & "WScript.Shell" & Chr(34) & ")"
      Print #1, "Set oShellLink = WSHShell.CreateShortCut(" & Chr(34) & lnkPath & lnkName & ".lnk" & Chr(34) & ")"
      Print #1, "oShellLink.TargetPath =" & Chr(34) & ExePath & Chr(34)
      Print #1, "oShellLink.Arguments=""""""" & AppFullName & """"""""
      Print #1, "oShellLink.WorkingDirectory=" & Chr(34) & CStr(SysCmd(acSysCmdAccessDir)) & Chr(34)
      Print #1, "oShellLink.Save"
  Close #1
  If Shell("wscript """ & lnkPath & "tmp.vbs""") <> 0 Then
  Call SleepEx(3000, 0)
  FileSystem.Kill lnkPath & "tmp.vbs"
  End If
  MsgBox "您已成功創建了一個快捷方式在桌面，您可以使用它更快速的打開應用程式!", vbInformation
End Sub


二、文件拷貝更新：
  If TEMPS <> rs("VersionNO") Then
     If MsgBox("當前專案已有新版本,您需要更新以使用新功能..." + vbNewLine + "按 [是] 進行更新,按 [否] 將繼續使用舊版本! 本次更新內容:" & vbNewLine & vbNewLine & rs("UpdateContent"), vbInformation + vbYesNo, "Update information...") = vbYes Then
         TargetPath = rs("UpdatePath")
         '更新模式
         Select Case rs("UpdateType")
            Case 0:                      '主程式更新
                If CopyTFile(TargetPath & rs("UpdateName"), CurDir & rs("UpdateName")) Then
                  DoCmd.SetWarnings False
                  MsgBox "Upgrade successed,the system will restart now.", vbInformation
                  WriteINI "AllI", "Version", rs("VersionNO"), CurDir & "Dlls\mscini.dll"
                  TEMPS = CurDir & rs("UpdateName")
                  Call CreateTSCut(TEMPS)
                  Shell CStr(SysCmd(acSysCmdAccessDir)) & "MSAccess.EXE """ & TEMPS & """", vbMaximizedFocus
                  DoCmd.Quit acQuitSaveNone
                Else  '---------------------更新失敗
                  MsgBox "Upgrade failer,please ask for the soft engineer!", vbExclamation
                  DoCmd.Quit
                End If
            Case 1:    '完全更新
                If CopyTFile(TargetPath & Left(CurrentProject.Name, Len(CurrentProject.Name) - 14) & rs("VersionNO") & ".ade", CurDir & Left(CurrentProject.Name, Len(CurrentProject.Name) - 14) & rs("VersionNO") & ".ade") Then
                    DeleteFld CurDir & "Dlls", True, False
                    CopyFld TargetPath & "DLLS", CurDir & "Dlls", True, True
                    DeleteFld CurDir & "Res", True, False
                    CopyFld TargetPath & "Res", CurDir & "Res", True, True
                    MsgBox "Upgrade successed,the system will restart now.", vbInformation
                    WriteINI "AllI", "Version", rs("VersionNO"), CurDir & "Dlls\mscini.dll"
                    TEMPS = CurDir & rs("UpdateName")
                    Shell CStr(SysCmd(acSysCmdAccessDir)) & "MSAccess.EXE """ & TEMPS & """", vbMaximizedFocus
                    DoCmd.Quit acQuitSaveNone
                Else  '---------------------更新失敗
                  MsgBox "Upgrade failer,please ask for the soft engineer!", vbExclamation
                  DoCmd.Quit
                End If
           Case 2:    '更新動態庫
                DeleteFld CurDir & "Dlls", True, False
                CopyFld TargetPath & "DLLS", CurDir & "Dlls", True, True
                WriteINI "AllI", "Version", rs("VersionNO"), CurDir & "Dlls\mscini.dll"
                MsgBox "Upgrade successed."
            Case 3:    '更新資源庫
                DeleteFld CurDir & "Res", True, False
                CopyFld TargetPath & "Res", CurDir & "Res", True, True
                WriteINI "AllI", "Version", rs("VersionNO"), CurDir & "Dlls\mscini.dll"
                MsgBox "Upgrade successed."
        
         End Select
     Else  '=========不進行更新
       Me.Caption = " Please log in..."
       Me.Repaint
       UserDept.SetFocus
       rs.Close
       Set rs = Nothing
       Exit Sub
     End If
  End If

三、應用程式鏈接和文件拷貝選擇更新：
  If TEMPS <> rs("UpdateName") Then
      Select Case MsgBox("當前專案已有新版本,您需要更新以使用新功能..." + vbNewLine + "按 [是] 使用安裝程式進行更新,按 [否]使用文件拷貝方式更新, 按[取消] 將繼續使用舊版本! 本次更新內容:" & vbNewLine & vbNewLine & rs("UpdateContent"), vbInformation + vbYesNoCancle, "Update information...")
      Case vbYes:  
                LabHyp.HyperlinkAddress = rs("UpdatePath") & rs("UpdateExe")
                LabHyp.Hyperlink.Follow True
                DoCmd.Quit acQuitSaveNone
      Case vbNo:
                If CopyTFile(rs("UpdatePath") & rs("UpdateName"), CurDir & rs("UpdateName")) Then
                  DoCmd.SetWarnings False
                  MsgBox "Upgrade successed,the system will restart now.", vbInformation
                  TEMPS = CurDir & rs("UpdateName")
                  Call CreateTSCut(TEMPS)
                  Shell CStr(SysCmd(acSysCmdAccessDir)) & "MSAccess.EXE """ & TEMPS & """", vbMaximizedFocus
                  DoCmd.Quit acQuitSaveNone
                Else  '---------------------Update failer
                  MsgBox "Upgrade failer,please ask for the soft engineer!", vbExclamation
                  DoCmd.Quit
                End If
      Case vbCancle:
                Me.Caption = " Please log in..."
                Me.Repaint
                UserDept.SetFocus
                rs.Close
                Set rs = Nothing
                Exit Sub
      End Select
  Else  '==========The same version does not need upgrading
    Me.UserDept.Enabled = True
    Me.UserPass.Enabled = True
    Me.TimerInterval = 0
  End If

  End If
四、其他更新模式：
　當前采用利用Winrar打包Access程式為EXE自解壓包，通過發送郵件給用戶進行更新,也非常方便。