vba upgrade

'本程序的版本号从1开始，逐次加大
'发布新版本后，除了将新版本放到下载目录中外，还要删除原文件或改名，程序在升级时找不到原旧文件名，才会向上推新的带版本号的文件名进行下载

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
Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Function CheckUrl(Url As String) As Boolean    '检测网络文件是否存在
    Dim XMLObject As Object
    Set XMLObject = CreateObject("Microsoft.XMLHTTP")
    XMLObject.Open "GET", Url, False
    XMLObject.send ""
    If XMLObject.Status = 200 Then
        CheckUrl = True
    Else
        CheckUrl = False
    End If
    Set XMLObject = Nothing
End Function

Sub MyUpgrade()    '下载升级EXCEL的主程序
    Dim PathStr As String, NewFileUrl As String, DownOk As Long, Vers%, i%, UrlPath$, FileName$, NewVers%
    Vers = Val(ThisWorkbook.BuiltinDocumentProperties("Category").Value)    '获取现有版本号，这个版本号写在文件的属性里，以免影响文件结构
    UrlPath = "http://222.209.208.142:81/UpFiles/"    '这是程序升级网址的URL路径，可根据您的路径修改
    FileName = "我的程序名.xls"    '这是原文件名，可根据您的程序名修改，用户改文件名，对此升级无影响
    NewFileUrl = UrlPath & Vers & FileName    '当前版本的完整地址
    PathStr = ThisWorkbook.FullName

    If CheckUrl(NewFileUrl) = False Then    '如果没有在升级网址找到当前版本，那么说明有新版本
        For i = Vers To Vers + 50    '继续查找新版本号，为了节省时间，所以只从当前版本号开始向上推50个版本号，如果超过50个版本都没升过级，那你也不是经常用
            NewFileUrl = UrlPath & i & FileName
            If CheckUrl(NewFileUrl) = True Then
                NewVers = i
                Exit For    '如果找到新的程序文件了就退出查找
            End If
        Next
        If NewVers > Vers Then    '此条件说明找到有新版本
            If MsgBox("检测到有新版本，是否立即升级？", vbYesNo + vbInformation, "升级") = vbNo Then Exit Sub
            ThisWorkbook.ChangeFileAccess xlReadOnly    '设为只读后才可对原旧文件进行操作
            'Kill PathStr'最好不要删除文件，升级成功后让用户自己手动删除，这里采用改名法，不然会重名错误
            Name PathStr As ThisWorkbook.Path & "\" & Replace(ThisWorkbook.Name, ".xls", "") & "(原文件).xls"
            DownOk = URLDownloadToFile(0, NewFileUrl, PathStr, 0, 0)    '下载的文件以原旧文件命名
            Call DeleteUrlCacheEntry(NewFileUrl)    '用这个删除缓存中下载的新程序文件，可以不要
            MsgBox "升级成功"
            ThisWorkbook.Close False '关闭文件，当然您可以不关而进行下面转移数据的工作
            '这里加入复制旧文件的数据到新文件中的代码，如果EXCEL程序与其数据是分开存放的，则更好
        End If
    End If
End Sub

Sub Issue()    '发布新版本,程序发布者专用,将生成的新文件放到下载目录里，必须删除旧文件
    With ThisWorkbook
        .BuiltinDocumentProperties("Category").Value = Val(.BuiltinDocumentProperties("Category").Value) + 1 & "为当前版本号"
        .Save
        .ChangeFileAccess xlReadOnly
        Name ThisWorkbook.FullName As ThisWorkbook.Path & "\" & Val(ThisWorkbook.BuiltinDocumentProperties("Category").Value) & "我的程序名.xls"
        MsgBox "发布成功"
        .Close False
    End With
End Sub

转自[email protected]