<%
Sub UpWrite(Upurl,LocalUrl)
    Dim UpType
	LocalUrl=Replace(LocalUrl,"Admin/",AdminDir&"/") '传递到已更换后台目录下
	Call CreateDir(LocalUrl)
	UpType=Split(LocalUrl, ".")
	Select Case LCase(UpType(UBound(UpType)))
	Case "jpeg","gif","jpg","png","bmp","exe","doc","chm","rar","zip","wmv","rm"
	Call Save2Local(Upurl,server.MapPath(LocalUrl))
	Case else
	Call FSOSaveFile(LocalUrl, GetContent(Upurl))
	End Select
End Sub

Function UpIncContent()
    UpIncContent="<%"&vbCrLf
	UpIncContent=UpIncContent&"Dim LocalVersion,UpdateUrl"&vbCrLf
    UpIncContent=UpIncContent&"LocalVersion="""&Request("UpVersion")&""""&vbCrLf
	UpIncContent=UpIncContent&"UpDateUrl=chr(104)&chr(116)&chr(116)&chr(112)&chr(58)&chr(47)&chr(47)&chr(119)&chr(119)&chr(119)&chr(46)&chr(109)&chr(101)&chr(108)&chr(121)&chr(121)&chr(115)&chr(111)&chr(102)&chr(116)&chr(46)&chr(99)&chr(111)&chr(109)&chr(47)&chr(117)&chr(112)&chr(100)&chr(97)&chr(116)&chr(101)&chr(47)&chr(50)&chr(48)&chr(48)&chr(55)&chr(47)&chr(70)&chr(114)&chr(101)&chr(101)&chr(47)"&vbCrLf
	UpIncContent=UpIncContent&"%"&">"
End Function

Function FSOSaveFile(FileName, Content)
	  On Error Resume Next
		Dim FSO, FileObj
		Set FSO = Server.CreateObject("Scripting.FileSystemObject")
		Set FileObj = FSO.CreateTextFile(Server.MapPath(FileName), True)
		FileObj.Write Content
		FileObj.Close    
		Set FileObj = Nothing
		Set FSO = Nothing
End Function

Private function CreateDir1(ByVal strLocalPath)
Dim i, strPath, objFolder, tmpPath, tmptPath
Dim arrPathList, intLevel

'On Error Resume Next
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
   
Function CreateDir(strLocalPath)
    Dim strpath,objFolder,arrPathList,i,intLevel,tmpPath,tmptpath
    strPath     = Replace(strLocalPath, "\", "/")
    Set objFolder  = server.CreateObject("Scripting.FileSystemObject")
    arrPathList   = Split(strPath, "/")
    intLevel     = UBound(arrPathList)-1
    For I = 1 To intLevel
     If I = 1 Then
      tmptPath = "/"&arrPathList(1) & "/"
     Else
      tmptPath = tmptPath & arrPathList(I) & "/"
     End If
     tmpPath = Left(tmptPath, Len(tmptPath) - 1)
     If Not objFolder.FolderExists(Server.MapPath(tmpPath)) Then objFolder.CreateFolder Server.MapPath(tmpPath)
    Next
    Set objFolder = Nothing
End function

function getHTTPimg(url)
on error resume next
dim http
set http=server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then exit function
getHTTPimg=Http.responseBody
set http=nothing
if err.number<>0 then err.Clear 
end function

function Save2Local(from,tofile)
	on error resume next
	dim geturl,objStream,imgs
	geturl=trim(from)
	imgs=gethttpimg(geturl)
	Set objStream = Server.CreateObject("ADODB"&".Stream")
	objStream.Type =1
	objStream.Open
	objstream.write imgs
	objstream.SaveToFile tofile,2
	objstream.Close()
	set objstream=nothing
end function

Function GetContent(strUrl)
	GetContent = ""
	Dim oXhttp, strContent
	Set oXhttp = Server.CreateObject("Microsoft.XMLHTTP")
	'On Error Resume Next 
	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

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

'编码转换 2进制 => 字符串
Function sDoCreateFile(strFileName, ByRef strContent)
	sDoCreateFile = False
	Dim strPath
	strPath = Left(strFileName, InstrRev(strFileName, "\", -1, 1))
	Rem ## 检测路径及文件名有效性
	If Not(CreateDir(strPath)) Then Exit function
	'If Not(CheckFileName(strFileName)) Then Exit function
	
	'response.Write(strFileName)
	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
'
'
Function toNum(s, default)
	s=Replace(s,".","")
	If IsNumeric(s) and s <> "" then
	 toNum = CLng(s)
	Else
	 toNum = default
	End If
End function
%>

