VB创建一个自动升级的程序

3,180 人次阅读

共计 4699 个字符，预计需要花费 12 分钟才能阅读完成。

最近由于工作需要，给自己负责的产品制作一个可用于快速计算某些参数的通用小程序，由于最终需要分发给多人使用，但是在源码编制过程中的疏忽，会留下Bug。同时，为了避免每次更新升级程序之后，需要重新分发，确保每个人都在使用最新版本的源码所造成的重复性工作，所以需要在源码中嵌入一段自我升级的功能源码。

由于自己在VB编程方面，其实也是一个刚入门的人而已，所以参考了不少LiveUpdate的VB源码，再次对他们表示感谢，从他们的例子中，我得到了灵感和启发，所以完成了这段源码的编制。

具体过程和原理：

①使用外部文件（INI文件等），定义程序版本号，定义升级程序存储位置等信息用于提供校检；

②在主程序（MainApp.exe）窗口Load阶段，读取本地INI文件中版本号，升级程序信息，服务器中INI文件版本号

③比较两个版本号，若服务器中版本号比本地新，则运行更新程序（RunUpdate.exe）

④升级程序拷贝服务器中程序到本地，更新版本文件（INI文件）

⑤升级程序注销自身，启动主程序。

⑥升级完成。

当然，其中涉及到一些错误处理，比如无法连接到服务器情况，服务器或者本地文件缺失情况，需要单独作出错误处理，这里不讨论。各位相信会自己完成处理。

这里涉及到三段源码，分别摘录如下，各位如有问题，可以一起讨论。

1，MainApp.exe中Load阶段判断：

[php]
Private Sub MDIForm_Load()
‘确定启动检查是否有新版本
Dim ThisAppOldVersion As String
Dim ThisAppNewVersion As String
Dim ThisAppCheckFile As String
Dim ThisAppName As String
Dim AppUpdateFile As String
AppUpdateFile = GetIniStr(App.Path & "updatecheck.ini", "Config", "AppUpdateFile")
ThisAppCheckFile = GetIniStr(App.Path & "updatecheck.ini", "Config", "AppCheckFile")
ThisAppOldVersion = GetIniStr(App.Path & "updatecheck.ini", "Config", "Version")
ThisAppNewVersion = GetIniStr(ThisAppCheckFile, "Config", "Version")
ThisAppName = GetIniStr(ThisAppCheckFile, "Config", "AppName")
On Error Resume Next ‘更新错误仍然可以运行程序
If ThisAppNewVersion > ThisAppOldVersion Then
Shell App.Path & "RunUpdate.exe", vbNormalFocus ‘其中RunUpdate.exe即为更新升级程序
Unload Me
End If
End Sub
[/php]

updatecheck.ini即为存储基本程序信息的INI文件，其中大家完全可以把这段写死，不用这么多变量，我之所以这么留着，是为了能够使这个升级程序通用。

2、INI文件读写模块

[php]
Option Explicit

Private Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal pFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSection Lib "KERNEL32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
‘*************************************
‘目的:写入数据至Ini文件

‘输入: FileName 文件名
‘ AppName 项目名
‘ In_Key 键名
‘ In_Data 键名上的数值

‘返回: 写入成功 True
‘ 写入失败 False

‘*************************************

Public Function WriteIniStr(ByVal FileName As String, ByVal AppName As String, ByVal In_Key As String, ByVal In_Data As String) As Boolean
On Error GoTo WriteIniStrErr
WriteIniStr = True
If VBA.Trim(In_Data) = "" Or VBA.Trim(In_Key) = "" Or VBA.Trim(AppName) = "" Then
GoTo WriteIniStrErr
Else
WritePrivateProfileString AppName, In_Key, In_Data, FileName
End If
Exit Function
WriteIniStrErr:
Err.Clear
WriteIniStr = False
End Function

‘*************************************
‘目的:从Ini文件中读取数据

‘输入: FileName 文件名
‘ AppName 项目名
‘ In_Key 键名

‘返回: 取得给定键名上的数据

‘*************************************

Public Function GetIniStr(ByVal FileName As String, ByVal AppName As String, ByVal In_Key As String) As String
On Error GoTo GetIniStrErr
If VBA.Trim(In_Key) = "" Then
GoTo GetIniStrErr
End If
Dim GetStr As String
GetStr = VBA.String(128, 0)
GetPrivateProfileString AppName, In_Key, "", GetStr, 256, FileName
GetStr = VBA.Replace(GetStr, VBA.Chr(0), "")
If GetStr = "" Then
GoTo GetIniStrErr
Else
GetIniStr = GetStr
GetStr = ""
End If
Exit Function
GetIniStrErr:
Err.Clear
GetIniStr = ""
GetStr = ""
End Function

‘Option Explicit

‘遍历ini文件 , 某个主键下的所有Key
Public Function GetInfoSection(strSection As String, strIniFile As String) As String()
Dim strReturn As String * 32767
Dim strTmp As String
Dim nStart As Integer
Dim nEnd As Integer
Dim i As Integer
Dim sArray() As String

Call GetPrivateProfileSection(strSection, strReturn, Len(strReturn), strIniFile)

strTmp = strReturn
i = 1
Do While strTmp <> ""
nStart = nEnd + 1
nEnd = InStr(nStart, strReturn, vbNullChar)
strTmp = Mid$(strReturn, nStart, nEnd – nStart)
If Len(strTmp) > 0 Then
ReDim Preserve sArray(1 To i)
sArray(i) = strTmp
i = i + 1
End If
Loop
GetInfoSection = sArray

End Function
[/php]

这个模块我直接借用别人写好的了。就不解释了。

3、升级程序源码

[php]
Option Explicit
Private Sub Form_Load()
Dim ThisAppOldVersion As String
Dim ThisAppNewVersion As String
Dim ThisAppCheckFile As String
Dim ThisAppName As String
Dim AppUpdateFile As String
ThisAppCheckFile = GetIniStr(App.Path & "updatecheck.ini", "Config", "AppCheckFile")
AppUpdateFile = GetIniStr(App.Path & "updatecheck.ini", "Config", "AppUpdateFile")
ThisAppOldVersion = GetIniStr(App.Path & "updatecheck.ini", "Config", "Version")
ThisAppNewVersion = GetIniStr(ThisAppCheckFile, "Config", "Version")
ThisAppName = GetIniStr(ThisAppCheckFile, "Config", "AppName")
If ThisAppNewVersion > ThisAppOldVersion Then
FileCopy AppUpdateFile, App.Path & "" & ThisAppName & ".exe"
FileCopy ThisAppCheckFile, App.Path & "updatecheck.ini"
Shell App.Path & "" & ThisAppName & ".exe", vbNormalFocus
Unload Me
Else
Shell App.Path & "" & ThisAppName & ".exe", vbNormalFocus
Unload Me
End If
End Sub
[/php]