function.asp

功能介绍： 一、会员功能模块 1、站内短信发布(设计中) 2、书架收藏夹 3、发表评论(功能不完善) 4、申请作家(与添书员整合) 5、申请添书员(与作家整合) 6、申请更新员

<%
'==================================================
'函数名：GetHttpPage
'作  用：获取网页源码
'参  数：HttpUrl ------网页地址
'参  数：Cset ---------网页编码类型
'==================================================
Function GetHttpPage(HttpUrl,Cset)
	If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
		GetHttpPage="$False$"
		Exit Function
	End If
	If IsNull(Cset)=True Or Cset="$False$" Then
		Cset="GB2312"
	end if
	const TimeInterval=100
	'设定时间间隔
	'如果下载时间很慢，就写成120秒
	const lResolve=10
	'解析域名超时时间,秒
	const lConnect=10
	'连接站点超时时间,秒
	const lSend=10
	'发送数据请求超时时间,秒
	const lReceive=50
	'下载数据超时时间,秒
	Dim Http
	Set Http=server.createobject("MSXML2.ServerXMLHTTP")
	http.setTimeouts lResolve*1000,lConnect*1000,lSend*1000,lReceive*1000
	Http.open "GET",HttpUrl,False
	On Error Resume Next
	Http.Send()
	Select Case http.readyState
		Case 0
			GetHttpPage="$False$"
			response.Write "<li>对象初始化失败</li>"
			Err.Clear
			set http=nothing
			Exit Function
		Case 1
			GetHttpPage="$False$"
			response.Write "<li>域名分析超时/连接站点超时</li>"
			Err.Clear
			set http=nothing
			Exit Function
		Case 2
			GetHttpPage="$False$"
			response.Write "<li>发送数据请求超时,是不是服务器出故障了</li>"
			Err.Clear
			set http=nothing
			Exit Function
		Case 3
			GetHttpPage="$False$"
			response.Write "<li>数据下载超时/等待反馈时间超时</li>"
			Err.Clear
			set http=nothing
			Exit Function
		Case 4
			'下载成功
	End Select
	If http.status<>200  then
		GetHttpPage="$False$"
		response.Write "<li>下载失败"&Err.description&"</li>"
		Err.Clear
		set http=nothing
		Exit Function
	END IF
	GetHTTPPage=bytesToBSTR(Http.responseBody,Cset)
	Set Http=Nothing
	If Err.number<>0 then
		Err.Clear
	End If
End Function

'==================================================
'函数名：BytesToBstr
'作  用：将获取的源码转换为中文
'参  数：Body ------要转换的变量
'参  数：Cset ------要转换的类型
'==================================================
Function BytesToBstr(Body,Cset)
	Dim Objstream
	Set Objstream = Server.CreateObject("adodb.stream")
	objstream.Type = 1
	objstream.Mode =3
	objstream.Open
	objstream.Write body
	objstream.Position = 0
	objstream.Type = 2
	objstream.Charset = Cset
	BytesToBstr = objstream.ReadText 
	objstream.Close
	set objstream = nothing
End Function

'==================================================
'函数名：PostHttpPage
'作  用：登录
'==================================================
Function PostHttpPage(RefererUrl,PostUrl,PostData) 
	 Dim xmlHttp 
	 Dim RetStr		
	 Set xmlHttp = CreateObject("Msxml2.ServerXMLHTTP")  
	 xmlHttp.Open "POST", PostUrl, False
	 XmlHTTP.setRequestHeader "Content-Length",Len(PostData) 
	 xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
	 xmlHttp.setRequestHeader "Referer", RefererUrl
	 xmlHttp.Send PostData 
	 If Err.Number <> 0 Then 
		  Set xmlHttp=Nothing
		  PostHttpPage = "$False$"
		  Exit Function
	 End If
'	 PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
	 Set xmlHttp = nothing
End Function 

'==================================================
'函数名：UrlEncoding
'作  用：转换编码
'==================================================
Function UrlEncoding(DataStr)
	 Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
	 StrReturn = ""
	 For Si = 1 To Len(DataStr)
		  ThisChr = Mid(DataStr,Si,1)
		  If Abs(Asc(ThisChr)) < &HFF Then
				StrReturn = StrReturn & ThisChr
		  Else
				InnerCode = Asc(ThisChr)
				If InnerCode < 0 Then
					InnerCode = InnerCode + &H10000
				End If
				Hight8 = (InnerCode  And &HFF00)\ &HFF
				Low8 = InnerCode And &HFF
				StrReturn = StrReturn & "%" & Hex(Hight8) &  "%" & Hex(Low8)
		  End If
	 Next
	 UrlEncoding = StrReturn
End Function

'==================================================
'函数名：GetBody
'作  用：截取字符串
'参  数：ConStr ------将要截取的字符串
'参  数：StartStr ------开始字符串
'参  数：OverStr ------结束字符串
'参  数：IncluL ------是否包含StartStr
'参  数：IncluR ------是否包含OverStr
'==================================================
Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
	If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then
		GetBody="$False$"
		Exit Function
	End If
	Dim ConStrTemp
	Dim Start,Over
	ConStrTemp=Lcase(ConStr)
	StartStr=Lcase(StartStr)
	OverStr=Lcase(OverStr)
	Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
	If Start<=0 then
		GetBody="$False$"
		Exit Function
	Else
		If IncluL=False Then
			Start=Start+LenB(StartStr)
		End If
	End If
	Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
	If Over<=0 Or Over<=Start then
		GetBody="$False$"
		Exit Function
	Else
		If IncluR=True Then
			Over=Over+LenB(OverStr)
		End If
	End If
	GetBody=MidB(ConStr,Start,Over-Start)
End Function

'==================================================
'函数名：GetArray
'作  用：提取链接地址，以$Array$分隔
'参  数：ConStr ------提取地址的原字符
'参  数：StartStr ------开始字符串
'参  数：OverStr ------结束字符串
'参  数：IncluL ------是否包含StartStr
'参  数：IncluR ------是否包含OverStr
'==================================================
Function GetArray(ConStr,StartStr,OverStr,IncluL,IncluR)
	If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or  IsNull(StartStr)=True Or IsNull(OverStr)=True Then
		GetArray="$False$"
		Exit Function
	End If
	Dim TempStr,TempStr2,objRegExp,Matches,Match
	TempStr=""
	Set objRegExp = New Regexp 
	objRegExp.IgnoreCase = True 
	objRegExp.Global = True
	objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
	Set Matches =objRegExp.Execute(ConStr) 
	For Each Match in Matches
		TempStr=TempStr & "$Array$" & Match.Value
	Next 
	Set Matches=nothing

	If TempStr="" Then
		GetArray="$False$"
		Exit Function
	End If
	TempStr=Right(TempStr,Len(TempStr)-7)
	If IncluL=False then
		objRegExp.Pattern =StartStr
		TempStr=objRegExp.Replace(TempStr,"")
	End if
	If IncluR=False then
		objRegExp.Pattern =OverStr
		TempStr=objRegExp.Replace(TempStr,"")
	End if
	Set objRegExp=nothing
	Set Matches=nothing
	
	If TempStr="" then
		GetArray="$False$"
	Else
		GetArray=TempStr
	End if
End Function


'==================================================
'函数名：DefiniteUrl
'作  用：将相对地址转换为绝对地址
'参  数：PrimitiveUrl ------要转换的相对地址
'参  数：ConsultUrl ------当前网页地址
'==================================================
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
	Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
	If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
		DefiniteUrl="$False$"
		Exit Function
	End If
	If Left(Lcase(ConsultUrl),7)<>"http://" Then
		ConsultUrl= "http://" & ConsultUrl
	End If
	ConsultUrl=Replace(ConsultUrl,"\","/")
	ConsultUrl=Replace(ConsultUrl,"://",":\\")
	PrimitiveUrl=Replace(PrimitiveUrl,"\","/")

	If Right(ConsultUrl,1)<>"/" Then
		If Instr(ConsultUrl,"/")>0 Then
			If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then	
			Else
				ConsultUrl=ConsultUrl & "/"
			End If
		Else
			ConsultUrl=ConsultUrl & "/"
		End If
	End If
	ConArray=Split(ConsultUrl,"/")

	If Left(LCase(PrimitiveUrl),7) = "http://" then
		DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
	ElseIf Left(PrimitiveUrl,1) = "/" Then
		DefiniteUrl=ConArray(0) & PrimitiveUrl
	ElseIf Left(PrimitiveUrl,2)="./" Then
		PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
		If Right(ConsultUrl,1)="/" Then	
			DefiniteUrl=ConsultUrl & PrimitiveUrl
		Else
			DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
		End If
	ElseIf Left(PrimitiveUrl,3)="../" then
		Do While Left(PrimitiveUrl,3)="../"
			PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
			Pi=Pi+1
		Loop				
		For Ci=0 to (Ubound(ConArray)-1-Pi)
			If DefiniteUrl<>"" Then
				DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
			Else
				DefiniteUrl=ConArray(Ci)
			End If
		Next
		DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
	Else
		If Instr(PrimitiveUrl,"/")>0 Then
			PriArray=Split(PrimitiveUrl,"/")
			If Instr(PriArray(0),".")>0 Then
				If Right(PrimitiveUrl,1)="/" Then
					DefiniteUrl="http:\\" & PrimitiveUrl
				Else
					If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then 
						DefiniteUrl="http:\\" & PrimitiveUrl
					Else
						DefiniteUrl="http:\\" & PrimitiveUrl & "/"
					End If
				End If		
			Else
				If Right(ConsultUrl,1)="/" Then	
					DefiniteUrl=ConsultUrl & PrimitiveUrl
				Else
					DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
				End If
			End If
		Else
			If Instr(PrimitiveUrl,".")>0 Then
				If Right(ConsultUrl,1)="/" Then
					If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
						DefiniteUrl="http:\\" & PrimitiveUrl & "/"
					Else
						DefiniteUrl=ConsultUrl & PrimitiveUrl
					End If
				Else
					If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
						DefiniteUrl="http:\\" & PrimitiveUrl & "/"
					Else
						DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
					End If
				End If
			Else
				If Right(ConsultUrl,1)="/" Then
					DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
				Else
					DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
				End If			
			End If
		End If
	End If
	If Left(DefiniteUrl,1)="/" then
	  DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
	End if
	If DefiniteUrl<>"" Then
		DefiniteUrl=Replace(DefiniteUrl,"//","/")
		DefiniteUrl=Replace(DefiniteUrl,":\\","://")
	Else
		DefiniteUrl="$False$"
	End If
End Function

'==================================================
'函数名：ReplaceSaveRemoteFile
'作  用：替换、保存远程图片
'参  数：ConStr ------ 要替换的字符串
'参  数：SaveTf ------ 是否保存文件，False不保存，True保存
'参  数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSaveRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
	If ConStr="$False$" or ConStr="" or InstallPath="" or strChannelDir="" Then
		ReplaceSaveRemoteFile=ConStr
		Exit Function
	End If
	Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2

	Set Re = New Regexp 
	Re.IgnoreCase = True 
	Re.Global = True
	Re.Pattern ="<img.+?>"
	Set Matches =Re.Execute(ConStr) 
	For Each Match in Matches
		If TempStr<>"" then 
			TempStr=TempStr & "$Array$" & Match.Value
		Else
			TempStr=Match.Value
		End if
	Next
	If TempStr<>"" Then
		TempArray=Split(TempStr,"$Array$")
		TempStr=""
		For Tempi=0 To Ubound(TempArray)
			Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
			Set Matches =Re.Execute(TempArray(Tempi)) 
			For Each Match in Matches
				If TempStr<>"" then 
					TempStr=TempStr & "$Array$" & Match.Value
				Else
					TempStr=Match.Value
				End if
			Next
		Next
	End if
	If TempStr<>"" Then
		Re.Pattern ="src\s*=\s*"
		TempStr=Re.Replace(TempStr,"")
	End If
	Set Matches=nothing
	Set Re=nothing
	If TempStr="" or IsNull(TempStr)=True Then
		ReplaceSaveRemoteFile=ConStr
		Exit function
	End if
	TempStr=Replace(TempStr,"""","")
	TempStr=Replace(TempStr,"'","")
	TempStr=Replace(TempStr," ","")
	Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
	DtNow=Now()
 '***********************************
	If SaveTf=True then
		SavePath=InstallPath&strChannelDir
			If CheckDir(InstallPath & strChannelDir)=False Then
				If Not CreateMultiFolder(InstallPath & strChannelDir) Then
				response.Write InstallPath & strChannelDir&"目录创建失败"
					SaveTf=False
				End If
			End If
	End If

	'去掉重复图片开始
	TempArray=Split(TempStr,"$Array$")
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
			TempStr=TempStr & "$Array$" & TempArray(Tempi)
		End If
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempArray=Split(TempStr,"$Array$")
	'去掉重复图片结束

	response.Write "<br>发现图片:<br>"&Replace(TempStr,"$Array$","<br>")

	'转换相对图片地址开始
	TempStr=""
	For Tempi=0 To Ubound(TempArray)
		TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
	Next
	TempStr=Right(TempStr,Len(TempStr)-7)
	TempStr=Replace(TempStr,Chr(0),"")
	TempArray2=Split(TempStr,"$Array$")
	TempStr=""
	'转换相对图片地址结束

	'图片替换/保存
	Set Re = New Regexp
	Re.IgnoreCase = True 
	Re.Global = True

	For Tempi=0 To Ubound(TempArray2)
'********************************