upload.asp

一个简单的新闻系统

			Case 1
				Call OutScript("parent.UploadError('file')")
			Case 2
				Call OutScript("parent.UploadError('size')")
		End Select
	End If
	Set oFile = oUpload.File("uploadfile")
	sFileExt = LCase(oFile.FileExt)
	Call CheckValidExt(sFileExt)
	sOriginalFileName = oFile.FileName
	sSaveFileName = GetRndFileName(sFileExt)
	Dim str_Mappath
	str_Mappath = sUploadDir & sSaveFileName
	sFileExt = LCase(Mid(str_Mappath, InstrRev(str_Mappath, ".") + 1))
	Call CheckValidExt(sFileExt)
	oFile.SaveToFile str_Mappath
	Set oFile = Nothing
	Set oUpload = Nothing
End Sub

Function GetRndFileName(sExt)
	Dim sRnd
	Randomize
	sRnd = Int(900 * Rnd) + 100
	GetRndFileName = FormatTime(Now(), 5) & sRnd & "." & sExt
End Function

Sub OutScript(str)
	If sAction <> "LOCAL" Then
		Response.Write "<script language=javascript>" & str & ";history.back()</script>"
	End If
	Response.End
End Sub

Sub OutScriptNoBack(str)
	Response.Write "<script language=javascript>" & str & "</script>"
End Sub

Sub CheckValidExt(sExt)
	Dim b, i, aExt
	b = False
	aExt = Split(sAllowExt, "|")
	For i = 0 To UBound(aExt)
		If LCase(aExt(i)) = sExt Then
			b = True
			Exit For
		End If
	Next
	If b = False Then
		Call OutScript("parent.UploadError('ext')")
	End If
End Sub

Sub InitUpload()
	sType = UCase(Trim(Request.QueryString("type")))
	sStyleName = Trim(Request.QueryString("style"))
	sCusDir = Trim(Request.QueryString("cusdir"))
	sParamSYFlag = Trim(Request.QueryString("syflag"))
	sCusDir = Replace(sCusDir, "\", "/")
	If Left(sCusDir, 1) = "/" Or Left(sCusDir, 1) = "." Or Right(sCusDir, 1) = "." Or InStr(sCusDir, "./") > 0 Or InStr(sCusDir, "/.") > 0 Or InStr(sCusDir, "//") > 0 Then
		sCusDir = ""
	End If
	Dim i, aStyleConfig, bValidStyle
	bValidStyle = False
	For i = 1 To Ubound(aStyle)
		aStyleConfig = Split(aStyle(i), "|||")
		If Lcase(sStyleName) = Lcase(aStyleConfig(0)) Then
			bValidStyle = True
			Exit For
		End If
	Next
	If bValidStyle = False Then
		OutScript("parent.UploadError('style')")
	End If
	sBaseUrl = aStyleConfig(19)
	nUploadObject = Clng(aStyleConfig(20))
	nAutoDir = CLng(aStyleConfig(21))
	sUploadDir = aStyleConfig(3)
	If sBaseUrl<>"3" Then
		If Left(sUploadDir, 1) <> "/" Then
			sUploadDir = "../" & sUploadDir
		End If
	End If
	Select Case sBaseUrl
		Case "0", "3"
			sContentPath = aStyleConfig(23)
		Case "1"
			sContentPath = RelativePath2RootPath(sUploadDir)
		Case "2"
			sContentPath = RootPath2DomainPath(RelativePath2RootPath(sUploadDir))
	End Select
	If sBaseUrl<>"3" Then
		sUploadDir = Server.Mappath(sUploadDir)
	End If
	If Right(sUploadDir,1)<>"\" Then
		sUploadDir = sUploadDir & "\"
	End If
	Select Case sType
		Case "REMOTE"
			sAllowExt = aStyleConfig(10)
			nAllowSize = Clng(aStyleConfig(15))
		Case "FILE"
			sAllowExt = aStyleConfig(6)
			nAllowSize = Clng(aStyleConfig(11))
		Case "MEDIA"
			sAllowExt = aStyleConfig(9)
			nAllowSize = Clng(aStyleConfig(14))
		Case "FLASH"
			sAllowExt = aStyleConfig(7)
			nAllowSize = Clng(aStyleConfig(12))
		Case "LOCAL"
			sAllowExt = aStyleConfig(44)
			nAllowSize = Clng(aStyleConfig(45))
		Case Else
			sAllowExt = aStyleConfig(8)
			nAllowSize = Clng(aStyleConfig(13))
	End Select
	nSLTFlag = Clng(aStyleConfig(29))
	nSLTMinSize = Clng(aStyleConfig(30))
	nSLTOkSize = Clng(aStyleConfig(31))
	nSYWZFlag = Clng(aStyleConfig(32))
	sSYText = aStyleConfig(33)
	sSYFontColor = aStyleConfig(34)
	nSYFontSize = Clng(aStyleConfig(35))
	sSYFontName = aStyleConfig(36)
	sSYPicPath = aStyleConfig(37)
	nSLTSYObject = Clng(aStyleConfig(38))
	sSLTSYExt = aStyleConfig(39)
	nSYWZMinWidth = Clng(aStyleConfig(40))
	sSYShadowColor = aStyleConfig(41)
	nSYShadowOffset = Clng(aStyleConfig(42))
	nSYWZMinHeight = Clng(aStyleConfig(46))
	nSYWZPosition = Clng(aStyleConfig(47))
	nSYWZTextWidth = Clng(aStyleConfig(48))
	nSYWZTextHeight = Clng(aStyleConfig(49))
	nSYWZPaddingH = Clng(aStyleConfig(50))
	nSYWZPaddingV = Clng(aStyleConfig(51))
	nSYTPFlag = Clng(aStyleConfig(52))
	nSYTPMinWidth = Clng(aStyleConfig(53))
	nSYTPMinHeight = Clng(aStyleConfig(54))
	nSYTPPosition = Clng(aStyleConfig(55))
	nSYTPPaddingH = Clng(aStyleConfig(56))
	nSYTPPaddingV = Clng(aStyleConfig(57))
	nSYTPImageWidth = Clng(aStyleConfig(58))
	nSYTPImageHeight = Clng(aStyleConfig(59))
	nSYTPOpacity = CDbl(aStyleConfig(60))
	nCusDirFlag = Clng(aStyleConfig(61))
	If nSYWZFlag=2 Then
		If sParamSYFlag = "1" Then
			nSYWZFlag = 1
		Else
			nSYWZFlag = 0
		End If
	End If
	If nSYTPFlag=2 Then
		If sParamSYFlag = "1" Then
			nSYTPFlag = 1
		Else
			nSYTPFlag = 0
		End If
	End If
End Sub

Function RelativePath2RootPath(url)
	Dim sTempUrl
	sTempUrl = url
	If Left(sTempUrl, 1) = "/" Then
		RelativePath2RootPath = sTempUrl
		Exit Function
	End If
	Dim sWebEditorPath
	sWebEditorPath = Request.ServerVariables("SCRIPT_NAME")
	sWebEditorPath = Left(sWebEditorPath, InstrRev(sWebEditorPath, "/") - 1)
	Do While Left(sTempUrl, 3) = "../"
		sTempUrl = Mid(sTempUrl, 4)
		sWebEditorPath = Left(sWebEditorPath, InstrRev(sWebEditorPath, "/") - 1)
	Loop
	RelativePath2RootPath = sWebEditorPath & "/" & sTempUrl
End Function

Function RootPath2DomainPath(url)
	Dim sHost, sPort
	sHost = Split(Request.ServerVariables("SERVER_PROTOCOL"), "/")(0) & "://" & Request.ServerVariables("HTTP_HOST")
	sPort = Request.ServerVariables("SERVER_PORT")
	If sPort <> "80" Then
		sHost = sHost & ":" & sPort
	End If
	RootPath2DomainPath = sHost & url
End Function

Function ReplaceRemoteUrl(sHTML, sExt)
	Dim s_Content
	s_Content = sHTML
	If IsObjInstalled("Microsoft.XMLHTTP") = False Or nAllowSize <= 0 then
		ReplaceRemoteUrl = s_Content
		Exit Function
	End If
	Dim re, RemoteFile, RemoteFileurl, SaveFileName, SaveFileType
	Set re = new RegExp
	re.IgnoreCase  = True
	re.Global = True
	re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}(([A-Za-z0-9_-])+[.]){1,}([A-Za-z0-9]{1,5})\/(\S+\.(" & sExt & ")))"
	Set RemoteFile = re.Execute(s_Content)
	Dim a_RemoteUrl(), n, i, bRepeat
	n = 0
	For Each RemoteFileurl in RemoteFile
		If n = 0 Then
			n = n + 1
			Redim a_RemoteUrl(n)
			a_RemoteUrl(n) = RemoteFileurl
		Else
			bRepeat = False
			For i = 1 To UBound(a_RemoteUrl)
				If UCase(RemoteFileurl) = UCase(a_RemoteUrl(i)) Then
					bRepeat = True
					Exit For
				End If
			Next
			If bRepeat = False Then
				n = n + 1
				Redim Preserve a_RemoteUrl(n)
				a_RemoteUrl(n) = RemoteFileurl
			End If
		End If		
	Next
	nFileNum = 0
	For i = 1 To n
		SaveFileType = Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), ".") + 1)
		SaveFileName = GetRndFileName(SaveFileType)
		If SaveRemoteFile(SaveFileName, a_RemoteUrl(i)) = True Then
			nFileNum = nFileNum + 1
				If nFileNum > 1 Then
					sOriginalFileName = sOriginalFileName & "|"
					sSaveFileName = sSaveFileName & "|"
					sPathFileName = sPathFileName & "|"
				End If
			sOriginalFileName = sOriginalFileName & Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), "/") + 1)
			sSaveFileName = sSaveFileName & SaveFileName
			sPathFileName = sPathFileName & sContentPath & SaveFileName
			s_Content = Replace(s_Content, a_RemoteUrl(i), sContentPath & SaveFileName, 1, -1, 1)
		End If
	Next
	ReplaceRemoteUrl = s_Content
End Function

Function SaveRemoteFile(s_LocalFileName, s_RemoteFileUrl)
	Dim Ads, Retrieval, GetRemoteData
	Dim bError
	bError = False
	SaveRemoteFile = False
	On Error Resume Next
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", s_RemoteFileUrl, False, "", ""
		.Send
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	If LenB(GetRemoteData) > nAllowSize*1024 Then
		bError = True
	Else
		Set Ads = Server.CreateObject("Adodb." & "Stream")
		With Ads
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile sUploadDir & s_LocalFileName, 2
			Call makeImageSY(sUploadDir, s_LocalFileName)
			.Cancel()
			.Close()
		End With
		Set Ads=nothing
	End If
	If Err.Number = 0 And bError = False Then
		SaveRemoteFile = True
	Else
		Err.Clear
	End If
End Function

Function IsObjInstalled(strClassString)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

Function inHTML(str)
	Dim sTemp
	sTemp = str
	inHTML = ""
	If IsNull(sTemp) = True Then
		Exit Function
	End If
	sTemp = Replace(sTemp, "&", "&amp;")
	sTemp = Replace(sTemp, "<", "&lt;")
	sTemp = Replace(sTemp, ">", "&gt;")
	sTemp = Replace(sTemp, Chr(34), "&quot;")
	inHTML = sTemp
End Function

Function FormatTime(s_Time, n_Flag)
	Dim y, m, d, h, mi, s
	FormatTime = ""
	If IsDate(s_Time) = False Then Exit Function
	y = cstr(year(s_Time))
	m = cstr(month(s_Time))
	If len(m) = 1 Then m = "0" & m
	d = cstr(day(s_Time))
	If len(d) = 1 Then d = "0" & d
	h = cstr(hour(s_Time))
	If len(h) = 1 Then h = "0" & h
	mi = cstr(minute(s_Time))
	If len(mi) = 1 Then mi = "0" & mi
	s = cstr(second(s_Time))
	If len(s) = 1 Then s = "0" & s
	Select Case n_Flag
		Case 1
			FormatTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
		Case 2
			FormatTime = y & "-" & m & "-" & d
		Case 3
			FormatTime = h & ":" & mi & ":" & s
		Case 4
			FormatTime = y & m & d
		Case 5
			FormatTime = y & m & d & h & mi & s
	End Select
End Function
%>