你的软件也可象游戏软件一样互联网（非局域网）自动更新

时　间:2009-03-06 08:40:13
作　者:MichaelJiang   ID：104  城市：杭州
摘　要:互联网自动更新:
1、在我们发布做好的程序给客户使用后，使用客户较多，当有些小小的改动时，要去一个客户一个客户
通知，较麻烦！那有没有象瑞星及游戏那样自动查找是否发布了新版本并自动下载安装的方法呢？当然
有了（没有做不到，只有想不到嘛）。
2、你要有一个FTP或者一个可以上传及直接下载的网站（用于存放最新的客户端及版本信息）。
3、在发布更新时，为了减小客户端下载文件所需的时间，我们一般会压缩成ZIP或RAR文件，所以客户端
还得包含解压的程序（RAR）。
4、更新后为了能直接使用，所以最好你的程序是用另一个文件打开(如：你的程序是B，那你要先打开A
，再用A检查是否下载安装了更新，如果安装了，即COPY更新的程序TEM到B，再打开B，关闭A，因为直接
替换会造成ACCESS损坏）。
正　文:

互联网自动更新:
1、在我们发布做好的程序给客户使用后，使用客户较多，当有些小小的改动时，要去一个客户一个客户
通知，较麻烦！那有没有象瑞星及游戏那样自动查找是否发布了新版本并自动下载安装的方法呢？当然
有了（没有做不到，只有想不到嘛）。
2、你要有一个FTP或者一个可以上传及直接下载的网站（用于存放最新的客户端及版本信息）。
3、在发布更新时，为了减小客户端下载文件所需的时间，我们一般会压缩成ZIP或RAR文件，所以客户端
还得包含解压的程序（RAR）。
4、更新后为了能直接使用，所以最好你的程序是用另一个文件打开(如：你的程序是B，那你要先打开A
，再用A检查是否下载安装了更新，如果安装了，即COPY更新的程序TEM到B，再打开B，关闭A，因为直接
替换会造成ACCESS损坏）。
5、以下是操作方法及代码（等有空时再做个例放上来，或者谁帮做做例吧 ）。
'更新.txt必须含：
'标识符TRUE，检测是否联网
'（因未联网也会下载到一个错误的网页）如（true）
'                版本相关信息        如（dat版本:3.0版）
'                更新文件下载地址    如（dat地址:http://192.168.1.5/web/3.0.rar下载)
'                更新文件大小信息    如（DATSZ:16535K"）
以下内容需要回复才能看到
'用以下代码从网络读取版本信息文件：
Function uphtml()           '从网络读取网页文件内容
uphtml = getHTTPPage("http://192.168.1.5/web/更新.txt")
End Function
Function getHTTPPage(URL)                  '从网络读取文件
    Dim http
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", URL, False
    http.Send
    If http.ReadyState <> 4 Then
        Exit Function
    End If
    getHTTPPage = BytesToBstr(http.responseBody, "GB2312")
    Set http = Nothing
    If Err.Number <> 0 Then Err.Clear
End Function
Function BytesToBstr(body, Cset)                   '从网络读取文件
    Dim objstream
    Set objstream = CreateObject("adodb.stream")
    objstream.Type = 1
    objstream.Mode = 3
    objstream.Open
    objstream.Write body
    objstream.Position = 0
    objstream.Type = 2
    objstream.Charset = Cset
    BytesToBstr = objstream.ReadText
    objstream.Close
    Set objstream = Nothing
End Function
'取相关信息
Function Vip()  As Boolean      '检测是否联网
On Error Resume Next
    If Left(uphtml, 4) <> "true" Then
        vip =true
    Else:
        vip = false
    End If
End Function
Function Msize()             '更新包大小
Dim cq As Long, hs As Long
cq = InStr(1, uphtml, "DATSZ", 1)
hs = InStr(cq + 5, uphtml, "K", 1)
Msize = Val(Trim(Mid(uphtml, cq + 6, hs - cq - 6)))
End Function
Function Maddress()           '更新下载地址
Dim cq As Long, hs As Long
cq = InStr(1, uphtml, "dat地址", 1)
hs = InStr(cq + 5, uphtml, "下载", 1)
Maddress = Trim(Mid(uphtml, cq + 6, hs - cq - 6))
End Function
Function Nvison()            '最新版本
Dim cq As Long, hs As Long
cq = InStr(1, uphtml, "dat版本", 1)
hs = InStr(cq + 5, uphtml, "版", 1)
nviSon = Trim(Mid(uphtml, cq + 6, hs - cq - 6))
End Function

'下载文件的API
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal
pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As
Long, ByVal lpfnCB As Long) As Long 'API下载
'copy文件的API
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName
As String, ByVal lpNewFileName As String, Optional ByVal bFailIfExists As Long = 0) As Long
'GetFileInfo声明
Type FileInfo
    Name As String   '名字
    Size As Long
End Type
'下载文件的模块
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
'===============================================================================
'-函数名称:     GetFileInfo
'-功能描述:     获取文件信息
'-输入参数说明: 参数1: 必选 strFile As String 文件路径和名称
'-使用语法示例: Msgbox GetFileInfo("C:\Abc.txt").Size
'-使用注意:     需要引用Microsoft Scripting Runtime
'===============================================================================
Function GetFileInfo(strFile As String) As FileInfo
On Error Resume Next
Dim FileSize
Dim fsoSys As New Scripting.FileSystemObject
Dim fsoFile As File
Set fsoFile = fsoSys.GetFile(strFile)
     GetFileInfo.Size = fsoFile.Size
     Set fsoSys = Nothing
     Set fsoFile = Nothing
End Function
Function temrar()            '下载的更新文件保存位置
temrar = mepath & "dll\rardata.rar"
End Function
'比较版本并下载文件
Public Sub DlDat()
If Vip = False Then Exit Sub   '如果未联网，退出
If Val(Nvison) > Val(viron) Then DownloadFile Maddress, temrar
End Sub
Function fileRARpath()                       '本地RAR程序文件位置
    fileRARpath = mepath & "dll\rar.exe"
End Function
'解压RAR文件的模块
'参数：Rarfile 需解压的RAR文件，FilePath解压后保存路径
Function filerar(Rarfile, FilePath)      '解压文件
    Dim temstr As String    '参数
    temstr = " x -y "
    Shell fileRARpath & temstr & Rarfile & " " & filepath,vbHide
End Function
'一定时间（具体时间视下载的进度）后进行文件大小检查，并进行解压
Public Sub up()
    If GetFileInfo(temrar) = Msize Then Filerar temrar, mepath
End Sub
Function mepath()                                 '取得本地路径
    Dim lbmepath
    lbmepath = CurrentProject.Path
    If Right(lbmepath, 1) = "\" Then
        mepath = lbmepath
    Else:
        mepath = lbmepath & "\"
    End If
End Function
]

Access软件网官方交流QQ群 (群号:54525238) 　　　　　　Access源码网店