vba upgrade
2016-06-29 07:23
351 查看
'本程序的版本号从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
[size=xx-small]转自Jack.zhou.xmzdy@qq.com[/size]
'发布新版本后,除了将新版本放到下载目录中外,还要删除原文件或改名,程序在升级时找不到原旧文件名,才会向上推新的带版本号的文件名进行下载
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
[size=xx-small]转自Jack.zhou.xmzdy@qq.com[/size]
相关文章推荐
- vba rename name
- vba download web file
- VB6.0
- VAO和VBO
- [备忘]VB中几种常用数据类型的缩写
- C#/VB.NET Excel数据分列
- C#/VB.NET Excel数据分列
- vba 数据更新
- [VB] VB实现一个窗体的增删改查的demo
- 已经两天没学vb了,规划下接下去的进度
- 2016年VB图书253本推荐
- CATIA VBA二次开发(二) 快速入门之VBA IDE
- CATIA VBA二次开发(一)快速入门之宏脚本
- 五颗球
- 学习DVB知识的疑问与自我解答
- Ubuntu15下安装使用Vbox虚拟机
- Use VBA to update PPT from Excel
- GXT 3.1.1 的VBoxLayoutContainer 高度BUG
- VB脚本编辑器该进详解
- [备忘]一个不错的VB函数大全