<%
Class Cls_oUpdate
Public LocalVersion, LastVersion, FileType
Public UrlVersion, UrlUpdate, UpdateLocalPath, Info
Public UrlHistory
Private sstrVersionList, sarrVersionList, sintLocalVersion, sstrLocalVersion
Private sstrLogContent, sstrHistoryContent, sstrUrlUpdate, sstrUrlLocal
Private Sub Class_Initialize()
UrlVersion = ""
UrlUpdate = ""
UpdateLocalPath = "/"
UrlHistory = "history.htm"
Info = ""
LocalVersion = "1.0.0"
LastVersion = "1.0.0"
FileType = ".asp"
End Sub
Private Sub Class_Terminate()
End Sub
Public function doUpdate()
doUpdate = False
UrlVersion = Trim(UrlVersion)
UrlUpdate = Trim(UrlUpdate)
If (Left(UrlVersion, 7) <> "http://") Or (Left(UrlUpdate, 7) <> "http://") Then
Info = "版本检测网址为空, 升级网址为空或格式错误(#1)"
Exit function
End If
If Right(UrlUpdate, 1) <> "/" Then
sstrUrlUpdate = UrlUpdate & "/"
Else
sstrUrlUpdate = UrlUpdate
End If
If Right(UpdateLocalPath, 1) <> "/" Then
sstrUrlLocal = UpdateLocalPath & "/"
Else
sstrUrlLocal = UpdateLocalPath
End If
sstrLocalVersion = LocalVersion
sintLocalVersion = Replace(sstrLocalVersion, ".", "")
sintLocalVersion = toNum(sintLocalVersion, 0)
If IsLastVersion Then Exit function
doUpdate = NowUpdate()
LastVersion = sstrLocalVersion
End function
Private function IsLastVersion()
If iniVersionList Then
Dim i
IsLastVersion = True
For i = 0 to UBound(sarrVersionList)
If sarrVersionList(i) > sintLocalVersion Then
IsLastVersion = False
Info = "已经是最新版本!"
Exit For
End If
Next
Else
IsLastVersion = True
Info = "获取版本信息时出错!(#2)"
End If
End function
Private function iniVersionList()
iniVersionList = False
Dim strVersion
strVersion = getVersionList()
If strVersion = "" Then
Info = "出错......."
Exit function
End If
sstrVersionList = Replace(strVersion, " ", "")
sarrVersionList = Split(sstrVersionList, vbCrLf)
iniVersionList = True
End function
Private function getVersionList()
getVersionList = GetContent(UrlVersion)
End function
Private function NowUpdate()
Dim i
For i = UBound(sarrVersionList) to 0 step -1
Call doUpdateVersion(sarrVersionList(i))
Next
Info = "升级完成! & sstrUrlLocal & UrlHistory & """>查看"
End function
Private function doUpdateVersion(strVer)
doUpdateVersion = False
Dim intVer
intVer = toNum(Replace(strVer, ".", ""), 0)
If intVer <= sintLocalVersion Then
Exit function
End If
Dim strFileListContent, arrFileList, strUrlUpdate
strUrlUpdate = sstrUrlUpdate & intVer & FileType
strFileListContent = GetContent(strUrlUpdate)
If strFileListContent = "" Then
Exit function
End If
sintLocalVersion = intVer
sstrLocalVersion = strVer
Dim i, arrTmp
arrFileList = Split(strFileListContent, vbCrLf)
sstrLogContent = ""
sstrLogContent = sstrLogContent & strVer & ":" & vbCrLf
For i = 0 to UBound(arrFileList)
arrTmp = Split(arrFileList(i), "|")
sstrLogContent = sstrLogContent & vbTab & arrTmp(1)
Call doUpdateFile(intVer & "/" & arrTmp(0), arrTmp(1))
Next
sstrLogContent = sstrLogContent & Now() & vbCrLf
response.Write(""
& sstrLogContent & "")
Call sDoCreateFile(Server.MapPath(sstrUrlLocal & "Log" & intVer & ".htm"), _
""
& sstrLogContent & "")
Call sDoAppendFile(Server.MapPath(sstrUrlLocal & UrlHistory), ""
& _
strVer & "_______" & Now() & "" & vbCrLf)
End function
Private function doUpdateFile(strSourceFile, strTargetFile)
Dim strContent
strContent = GetContent(sstrUrlUpdate & strSourceFile)
If sDoCreateFile(Server.MapPath(sstrUrlLocal & strTargetFile), strContent) Then
sstrLogContent = sstrLogContent & " 成功" & vbCrLf
Else
sstrLogContent = sstrLogContent & " 失败" & vbCrLf
End If
End function
Private function GetContent(strUrl)
GetContent = ""
Dim oXhttp, strContent
Set oXhttp = Server.CreateObject("Microsoft.XMLHTTP")
With oXhttp
.Open "GET", strUrl, False, "", ""
.Send
If .readystate <> 4 Then Exit function
strContent = .Responsebody
strContent = sBytesToBstr(strContent)
End With
Set oXhttp = Nothing
If Err.Number <> 0 Then
response.Write(Err.Description)
Err.Clear
Exit function
End If
GetContent = strContent
End function
Private function sBytesToBstr(vIn)
dim objStream
set objStream = Server.CreateObject("adodb.stream")
objStream.Type = 1
objStream.Mode = 3
objStream.Open
objStream.Write vIn
objStream.Position = 0
objStream.Type = 2
objStream.Charset = "GB2312"
sBytesToBstr = objStream.ReadText
objStream.Close
set objStream = nothing
End function
Private function sDoCreateFile(strFileName, ByRef strContent)
sDoCreateFile = False
Dim strPath
strPath = Left(strFileName, InstrRev(strFileName, "\", -1, 1))
If Not(CreateDir(strPath)) Then Exit function
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(strFileName, ForWriting, True)
f.Write strContent
f.Close
Set fso = nothing
Set f = nothing
sDoCreateFile = True
End function
Private function sDoAppendFile(strFileName, ByRef strContent)
sDoAppendFile = False
Dim strPath
strPath = Left(strFileName, InstrRev(strFileName, "\", -1, 1))
If Not(CreateDir(strPath)) Then Exit function
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(strFileName, ForAppending, True)
f.Write strContent
f.Close
Set fso = nothing
Set f = nothing
sDoAppendFile = True
End function
Private function CreateDir(ByVal strLocalPath)
Dim i, strPath, objFolder, tmpPath, tmptPath
Dim arrPathList, intLevel
strPath = Replace(strLocalPath, "\", "/")
Set objFolder = server.CreateObject("Scripting.FileSystemObject")
arrPathList = Split(strPath, "/")
intLevel = UBound(arrPathList)
For I = 0 To intLevel
If I = 0 Then
tmptPath = arrPathList(0) & "/"
Else
tmptPath = tmptPath & arrPathList(I) & "/"
End If
tmpPath = Left(tmptPath, Len(tmptPath) - 1)
If Not objFolder.FolderExists(tmpPath) Then objFolder.CreateFolder tmpPath
Next
Set objFolder = Nothing
If Err.Number <> 0 Then
CreateDir = False
Err.Clear
Else
CreateDir = True
End If
End function
Private function toNum(s, default)
If IsNumeric(s) and s <> "" then
toNum = CLng(s)
Else
toNum = default
End If
End function
End Class
%>