|
|
楼主 |
发表于 2014-5-23 23:32
|
显示全部楼层
本帖最后由 kangatang 于 2014-5-24 00:31 编辑
将下面的代码拷贝到Thisworkbook中运行即可。
'////////////////////////////////////////////////////
'本程序由 ExcelHome Kangatang 提供; Version 3.0
'以下为程序自动升级模块;
''欢迎交流 QQ:5495771 Mail:tangjgang@163.com
'////////////////////////////////////////////////////
Private Sub workbook_open()
Dim sorceUrl, aid
sorceUrl = "http://www.excelpx.com/forum.php?mod=attachment&aid=Mjc5NjE1fDkyNTNiM2VlfDE0MDA4MzQ3MjV8NjI4NDY1fDMwMDY1NQ%3D%3D" ' 在这里输入代码压缩包的链接地址
aid = Split(sorceUrl, "aid=")(UBound(Split(sorceUrl, "aid=")))
Call CheckVersion(sorceUrl, aid)
'Application.OnTime Now + TimeValue("00:00:1"), "qureyinfo"
End Sub
Function get_exact_remotefile(downloadurl)
Dim TargetDir, WshSHell, XML, SourceDir, TargetFileName, temppath, Ver
Set WshSHell = CreateObject("WScript.Shell")
Set XML = CreateObject("Microsoft.XMLHTTP") ' ("WinHttp.WinHttpRequest.5.1") '
temppath = WshSHell.ExpandEnvironmentStrings("%temp%")
With XML
TargetFileName = temppath & "\下载代码并自动执行.rar"
.Open "GET", downloadurl, False
.setRequestHeader "If-Modified-Since", "0"
.Send
picAry = .responseBody
With CreateObject("ADODB.Stream"): .Type = 1: .Open: .Write picAry: .SaveToFile TargetFileName, 2: .Close: End With
End With
Set XML = Nothing
SourceDir = Chr(34) & TargetFileName & Chr(34)
TargetDir = Chr(34) & temppath & Chr(34)
Ver = get_exact_version
If CInt(Ver) <= 5 Then
WshSHell.Run "expand " & SourceDir & " -F:*.* " & TargetDir, 0, True
Else
WshSHell.Run "expand -I " & SourceDir & " -F:* " & TargetDir, 0, True
End If
get_exact_remotefile = temppath
Set WshSHell = Nothing
Kill TargetFileName
End Function
Function get_exact_version()
Dim WshSHell, helpFileName
Set WshSHell = CreateObject("WScript.Shell")
helpFileName = WshSHell.ExpandEnvironmentStrings("%temp%") & "\helpversion.txt"
WshSHell.Run "cmd /c expand /? > " & Chr(34) & helpFileName & Chr(34), 0, True
Set WshSHell = Nothing
Set RegEx = CreateObject("VBSCRIPT.REGEXP")
RegEx.Global = True
RegEx.Pattern = "\d\.\d\."
get_exact_version = Left(RegEx.Execute(ReadOut(helpFileName)).Item(0), 1)
Set RegEx = Nothing
'Kill TargetFileName
End Function
Private Sub CheckVersion(Url, aid)
Dim Lasttime, Updatetime, var As Integer
Lasttime = GetSetting("CheckVer", "update", "date_" & aid, "")
Lasttime = IIf(Lasttime = "", CDate("1900-1-1 00:01:00"), Lasttime)
Updatetime = CDate(get_mod_time(Url))
If DateAdd("s", 1, CDate(Lasttime)) < Updatetime Then
var = MsgBox("发现程序有更新，是否现在升级？", 1, "更新代码")
If var = 1 Then
Call updateCode(Url)
SaveSetting "CheckVer", "update", "date_" & aid, Updatetime
ThisWorkbook.Save
MsgBox "OK, 升级成功！"
End If
End If
End Sub
Private Function get_mod_time(Url)
Dim XML
Set XML = CreateObject("Microsoft.XMLHTTP")
With XML
.Open "HEAD", Url, False
.setRequestHeader "If-Modified-Since", "0"
.Send
Headinfo = .getallResponseHeaders
Mdt = .getResponseHeader("Last-Modified")
get_mod_time = CDate(Split(Split(Mdt, ",")(1), "GMT")(0)) + DateAdd("h", 8, timeGMT)
End With
Set XML = Nothing
End Function
Private Sub updateCode(Url)
Dim mdlname, updatesource, mdlnames, sourceworkbook, codebook
updatesource = get_exact_remotefile(Url)
mdlnames = Split(ReadOut(updatesource & "\readme.txt"), "$$$$")
On Error Resume Next
sourceworkbook = updatesource & "\" & mdlnames(0)
currentsh = ActiveSheet.Name
Application.DisplayAlerts = False
Application.EnableEvents = False
Set codebook = GetObject(sourceworkbook)
For i = LBound(mdlnames) + 1 To UBound(mdlnames)
For Each sht In ActiveWorkbook.Sheets
If sht.Name = mdlnames(i) Then sht.Delete
Next
codebook.Sheets(mdlnames(i)).Copy before:=ThisWorkbook.Sheets(1)
Next
ThisWorkbook.Sheets(currentsh).Select
codebook.Close False
Set codebook = Nothing
Application.EnableEvents = True
Kill sourceworkbook
End Sub
Private Function ReadOut(FullPath)
On Error Resume Next
Dim Fso, FileText
Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
Set FileText = Fso.OpenTextFile(FullPath, 1, True)
ReadOut = FileText.ReadAll
FileText.Close
End Function
|
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2014-5-23 23:03
