asp采集程序类

Function InsertHyperlinks(inText)Dim objRegExp, strBufDim objMatches,
objMatchDim Value, ReplaceValue, iStart, iEnd strBuf = “” iStart = 1
iEnd = 1 Set objRegExp = New RegExp objRegExp.Pattern =
“/b(www|http|/S+@)/S+/b”

然而有些情况只需要传递几个文件,而且文件体积并不太大,这种情况下使用组件则有点牛刀杀鸡的感觉,通过html自带的表单就可以实现需要的功能,关键在于后台接收程序的处理。
php处理上传做的很方便,上传文件的信息通过服务器自动处理到$_FILES数组中,开发者只需要使用的内置处理函数简单操作就可以啦。ASP开发者则没有这么幸运,官方并没有提供直接的处理方法,需要开发者自己设计,这时就需要开发者了解IIS对enctype=”multipart/form-data”表单的处理方式,IIS把enctype=”multipart/form-data”表单提交的数据存储成二进制数据,以二进制格式返回给开发者,开发者则需要通过LenB、MidB的字节处理函数来分析获取的上传内容,客户端发送的具体表单数据格式,可以了解下HTTP
RFC1867协议传输格式方面的知识。
下面是我处理多个文件上传的方法,包括php和asp两个版本。
php:WEBSITE_DIRROOT代表网站根目录: 复制代码 代码如下: up_name = $name; !empty &&
$this->up_ext = $ext; $this->up_rename = $rename;
$this->up_dir = WEBSITE_DIRROOT. $GLOBALS[‘cfg_upload_path’];
$this->InitUpload(); } else {
exit(‘upload文件域名称为空,初始化失败!’); } } private function
InitUpload() { if (is_array($_FILES[$this->up_name])) { $up_arr
= count($_FILES[$this->up_name]); $up_all =
count($_FILES[$this->up_name], 1); $up_cnt = / $up_arr; for ($i
= 0; $i < $up_cnt; $i ++) { if
($_FILES[$this->up_name][‘error’][$i] != 4) {
$this->up_files[] = array( ‘tmp_name’ =>
$_FILES[$this->up_name][‘tmp_name’][$i], ‘name’ =>
$_FILES[$this->up_name][‘name’][$i], ‘type’ =>
$_FILES[$this->up_name][‘type’][$i], ‘size’ =>
$_FILES[$this->up_name][‘size’][$i], ‘error’ =>
$_FILES[$this->up_name][‘error’][$i] ); } } $this->up_num
= count; } else { if (isset($_FILES[$this->up_name])) {
$this->up_files = array( ‘tmp_name’ =>
$_FILES[$this->up_name][‘tmp_name’], ‘name’ =>
$_FILES[$this->up_name][‘name’], ‘type’ =>
$_FILES[$this->up_name][‘type’], ‘size’ =>
$_FILES[$this->up_name][‘size’], ‘error’ =>
$_FILES[$this->up_name][‘error’] ); $this->up_num = 1; }
else { exit; } } $this->ChkUpload(); } private function ChkUpload() {
if { $up_mime = array(‘image/wbmp’, ‘image/bmp’, ‘image/gif’,
‘image/pjpeg’, ‘image/x-png’); foreach ($this->up_files as
$up_file) { $up_allw = false; foreach { if ($up_file[‘type’] ==
$mime) { $up_allw = true; break; } } !$up_allw &&
exit(‘不允许上传’.$up_file[‘type’].’格式的文件!’); if
($up_file[‘size’] / 1024 > $this->up_max) {
exit(‘不允许上传大于 ‘.$this->up_max.’K 的文件!’); } } } else {
foreach ($this->up_files as $up_file) { $up_ext = end(explode(‘.’,
$up_file[‘name’])); $up_allw = false; foreach ($this->up_ext as
$ext) { if { $up_allw = true; break; } } !$up_allw &&
exit(‘不允许上传.’.$up_ext.’格式的文件!’); if ($up_file[‘size’] /
1024 > $this->up_max) { exit(‘不允许上传大于
‘.$this->up_max.’K 的文件!’); } } } $this->Uploading(); }
private function Uploading() { if (IO::DIRCreate { if (chmod { if
(!empty { foreach ($this->up_files as $up_file) { if
(is_uploaded_file) { $file_name = $up_file[‘name’]; if {
$file_ext = end(explode; $file_rnd = substr, mt_rand; $file_name =
date.’_’.$file_rnd.’.’.$file_ext; } $file_name =
$this->up_dir.’/’.$file_name; if
(move_uploaded_file($up_file[‘tmp_name’], $file_name)) {
$this->up_ret[] = str_replace(WEBSITE_DIRROOT, ”, $file_name);
} else { exit; } } } } } else { exit; } } else { exit; } } public
function GetUpload() { return empty ? false : $this->up_ret; }
function __destruct() {} } ?> asp: 复制代码 代码如下: dataLen Then partLen =
dataLen – curRead streamTmp.Write Request.BinaryRead curRead = curRead +
partLen LetProgress appName, Array(curRead, dataLen, DateDiff,
folderPath) Loop streamTmp.Position = 0 formData = streamTmp.Read
streamTmp.Close Set streamTmp = Nothing Call ItemPosition End Function
Private Function LetProgress(byVal sName, byVal vArr) Application.Value
= Join End Function Private Function DelProgress
Application.Contents.Remove(“PROGRESS” & IPToNum End Function Private
Function ItemPosition Dim iStart, iLength : iStart = 1 Do Until
InStrB(iStart, formData, bSeparate) = 0 iStart = InStrB(iStart,
formData, bSeparate) + LenB + 14 iLength = InStrB(iStart, formData,
bSeparate) – iStart – 2 If Abs(iStart + 2 – LenB > 2 Then ReDim
Preserve itemStart ReDim Preserve itemLength itemStart = iStart
itemLength = iLength itemCount = itemCount + 1 End If Loop Call
FillItemValue End Function Private Function FillItemValue Dim dataPart,
bInfor Dim iStart : iStart = 1 Dim iCount : iCount = 0 Dim iCheck :
iCheck = StrToByte For i = 0 To itemCount – 1 ReDim Preserve itemName
ReDim Preserve itemData ReDim Preserve extenArr ReDim Preserve httpArr
ReDim Preserve dataStart ReDim Preserve dataLength dataPart =
MidB(formData, itemStart iStart = InStrB) + 1 iLength = InStrB(iStart,
dataPart, ChrB – iStart itemName = GetItemName(MidB(dataPart, iStart,
iLength)) iStart = InStrB + 4 iLength = LenB – iStart + 1 If InStrB >
0 Then bInfor = MidB(dataPart, 1, iStart – 5) extenArr = FileExtenName
httpArr = GetHttpContent If IsNothing Then itemData = “” dataStart = “”
dataLength = “” Else If Mid(folderPath, Len = “/” Then If fRename Then
itemData = folderPath & GetRandomName Else itemData = folderPath &
GetClientName & extenArr End If Else If fRename Then itemData =
folderPath & “/” & GetRandomName Else itemData = folderPath & “/” &
GetClientName & extenArr End If End If dataStart = itemStart + iStart –
2 dataLength = iLength End If Else extenArr = “” httpArr = “” itemData =
ByteToStr(MidB(dataPart, iStart, iLength)) dataStart = “” dataLength =
“” End If iCount = iCount + 1 Next Call ItemToColl End Function Private
Function GetItemName GetItemName = ByteToStr End Function Private
Function ItemToColl For i = 0 To itemCount – 1 If Not Form.Exists Then
Form.Add itemName End If Next End Function Private Function
FileExtenName Dim pContent, regEx pContent = GetClientPath If IsNothing
Then FileExtenName = “” Else Set regEx = New RegExp regEx.Pattern =
“^.+$” regEx.Global = False regEx.IgnoreCase = True FileExtenName =
regEx.Replace Set regEx = Nothing End If End Function Private Function
GetHttpContent Dim sInfor, regEx sInfor = ByteToStr Set regEx = New
RegExp regEx.Pattern = “^[Ss]+Content-Type:$” regEx.Global = False
regEx.IgnoreCase = True GetHttpContent = Trim(regEx.Replace Set regEx =
Nothing End Function Private Function GetRandomName Dim regEx, sTemp,
arrFields, n : n = 0 Set regEx = New RegExp regEx.Pattern = “[^d]+”
regEx.Global = True regEx.IgnoreCase = True sTemp = regEx.Replace & “-”
Set regEx = Nothing arrFields = Array(“0”, “1”, “2”, “3”, “4”, “5”, “6”,
“7”, “8”, “9”, _ “a”, “b”, “c”, “d”, “e”, “f”, “g”, “h”, “i”, “j”, _
“k”, “l”, “m”, “n”, “o”, “p”, “q”, “r”, “s”, “t”, _ “u”, “v”, “w”, “x”,
“y”, “z”, “A”, “B”, “C”, “D”, _ “E”, “F”, “G”, “H”, “I”, “J”, “K”, “L”,
“M”, “N”, _ “O”, “P”, “Q”, “R”, “S”, “T”, “U”, “V”, “W”, “X”, _ “Y”,
“Z”) Randomize Do While n < sLen sTemp = sTemp & CStr n = n + 1 Loop
GetRandomName = sTemp End Function Private Function GetClientName Dim
pContent, regEx pContent = GetClientPath If IsNothing Then GetClientName
= “” Else Set regEx = New RegExp regEx.Pattern = “^.*\[^\]+$”
regEx.Global = False regEx.IgnoreCase = True GetClientName =
regEx.Replace Set regEx = Nothing End If End Function Private Function
GetClientPath Dim sInfor, pStart, pLength, pContent sInfor = ByteToStr
pStart = InStr(1, sInfor, “filename=” & Chr + 10 pLength = InStr(pStart,
sInfor, Chr – pStart pContent = Mid(sInfor, pStart, pLength)
GetClientPath = pContent End Function Public Function SaveUploadFile Dim
isValidate Dim filePath, oStreamGet, oStreamPut isValidate = fPassed And
CheckFile If isValidate Then For i = 0 To itemCount – 1 If Not IsNothing
And Not IsNothing Then If dataLength = 0 Then itemData = “” Else
filePath = Server.MapPath If CreateFolder(“|”, ParentFolder Then Set
oStreamGet = Server.CreateObject oStreamGet.Type = 1 oStreamGet.Mode = 3
oStreamGet.Open oStreamGet.Write formData oStreamGet.Position =
dataStart Set oStreamPut = Server.CreateObject oStreamPut.Type = 1
oStreamPut.Mode = 3 oStreamPut.Open oStreamPut.Write oStreamGet.Read
oStreamPut.SaveToFile filePath, 2 oStreamGet.Close Set oStreamGet =
Nothing oStreamPut.Close Set oStreamPut = Nothing End If End If End If
Next IsFinished = True Else IsFinished = False End If End Function
Private Function CheckFile Dim oBoolean : oBoolean = True CheckFile =
oBoolean And CheckType And CheckSize End Function Private Function
CheckType Dim oBoolean : oBoolean = True If fileType = “*” Then
oBoolean = oBoolean And True Else For i = 0 To itemCount – 1 If Not
IsNothing Then If InStr(1, fileType, “|” & Ucase & “|”) > 0 Then If
fIMGOnly Then Dim sAllow : sAllow = “|GIF|PJPEG|X-PNG|BMP|” Dim aCheck :
aCheck = Split, “/”) Dim iCheck : iCheck = “|” & aCheck & “|” If InStr
> 0 Then oBoolean = oBoolean And True Else sErrors = sErrors & “表单
[ ” & itemName & ” ] 的文件格式错误!n” & _ “支持的格式为:” &
Replace(Mid(fileType, 2, Len, “|”, ” “) & “nn” oBoolean = oBoolean
And False End If Else oBoolean = oBoolean And True End If Else sErrors =
sErrors & “表单 [ ” & itemName & ” ] 的文件格式错误!n” & _
“支持的格式为:” & Replace(Mid(fileType, 2, Len, “|”, ” “) & “nn”
oBoolean = oBoolean And False End If End If Next End If CheckType =
oBoolean End Function Private Function CheckSize Dim oBoolean : oBoolean
= True If fileSize = “*” Then oBoolean = oBoolean And True Else For i =
0 To itemCount – 1 If Not IsNothing Then Dim tmpSize : tmpSize =
CDbl(FormatNumber / 1024, 2)) If tmpSize <= fileSize Then oBoolean =
oBoolean And True Else sErrors = sErrors & “表单 [ ” & itemName & ” ]
的文件大小 超出范围!n” & _ “支持大小范围:<= ” & fileSize & ”
KBnn” oBoolean = oBoolean And False End If End If Next End If
CheckSize = oBoolean End Function Private Function CreateFolder(byVal
sLine, byVal sPath) Dim oFso Set oFso =
Server.CreateObject(“Scripting.FileSystemObject”) If Not
oFso.FolderExists Then Dim regEx Set regEx = New RegExp regEx.Pattern =
“^$” regEx.Global = False regEx.IgnoreCase = True sLine = sLine &
regEx.Replace & “|” sPath = regEx.Replace If CreateFolder Then
CreateFolder = True Set regEx = Nothing Else If sLine = “|” Then
CreateFolder = True Else Dim sTemp : sTemp = Mid – 2) If InStrRev = 0
Then sLine = “|” sPath = sPath & “” & sTemp Else Dim Folder : Folder =
Mid(sTemp, InStrRev sLine = “|” & Mid(sTemp, 1, InStrRev & “|” sPath =
sPath & “” & Folder End If oFso.CreateFolder sPath If CreateFolder
Then CreateFolder = True End if End If Set oFso = Nothing End Function
Private Function ParentFolder Dim regEx Set regEx = New RegExp
regEx.Pattern = “^\[^\]*$” regEx.Global = True regEx.IgnoreCase
= True ParentFolder = regEx.Replace Set regEx = Nothing End Function
Private Function IsNothing IsNothing = CBool End Function Private
Function StrPadLeft(byVal sText, byVal sLen, byVal sChar) Dim sTemp :
sTemp = sText Do While Len < sLen : sTemp = sChar & sTemp : Loop
StrPadLeft = sTemp End Function Private Function StrToByte For i = 1 To
Len StrToByte = StrToByte & ChrB) Next End Function Private Function
ByteToStr Dim oStream Set oStream = Server.CreateObject oStream.Type = 2
oStream.Mode = 3 oStream.Open oStream.WriteText sByte oStream.Position =
0 oStream.CharSet = “gb2312” oStream.Position = 2 ByteToStr =
oStream.ReadText oStream.Close Set oStream = Nothing End Function
Private Function GetClientIPAddr If
IsNothing(GetServerVar(“HTTP_X_FORWARDED_FOR”)) Then GetClientIPAddr
= GetServerVar Else GetClientIPAddr =
GetServerVar(“HTTP_X_FORWARDED_FOR”) End If End Function Private
Function GetServerVar GetServerVar = Request.ServerVariables End
Function Private Function IPToNum Dim sIp_1, sIp_2, sIp_3, sIp_4 If
IsNumeric Then sIp_1 = Left – 1) sIp = Mid + 1) sIp_2 = Left – 1) sIp
= Mid + 1) sIp_3 = Left – 1) sIp_4 = Mid + 1) End If IPToNum = CInt *
256 * 256 * 256 + CInt * 256 * 256 + CInt * 256 + CInt – 1 End
Function REM CLASS-TERMINATE Private Sub Class_Terminate Call
DelProgress Form.RemoveAll Set Form = Nothing End Sub End Class %>

‘==================================================

‘ 判断URLs和emails. objRegExp.IgnoreCase = True

‘函数名:GetHttpPage

‘ 设置大小写不敏感.. objRegExp.Global = True

‘作 用:获取网页源码

‘ 全局适用. Set objMatches = objRegExp.Execute(inText) For Each objMatch
in objMatches iEnd = objMatch.FirstIndex strBuf = strBuf & Mid(inText,
iStart, iEnd-iStart+1) If InStr(1, objMatch.Value, “@”) Then strBuf =
strBuf & GetHref(objMatch.Value, “EMAIL”, “_BLANK”) Else strBuf =
strBuf & GetHref(objMatch.Value, “WEB”, “_BLANK”) End If iStart =
iEnd+objMatch.Length+1 Next strBuf = strBuf & Mid(inText, iStart)
InsertHyperlinks = strBufEnd FunctionFunction GetHref(url, urlType,
Target)Dim strBuf strBuf = “a href=””” If UCase(urlType) = “WEB” Then If
LCase(Left(url, 3)) = “www” Then strBuf = “a href=””URL:” & url &
“””超级链接:””” & _ Target & “””” & url & “/a” Else strBuf = “a
href=””” & url & “””超级链接:””” & _ Target & “””” & url & “/a” End If
ElseIf UCase(urlType) = “EMAIL” Then strBuf = “a href=””电子邮件地址:” &
url & “””链接目标:””” & _ Target & “””” & url & “/a” End If GetHref =
strBufEnd Function

‘参 数:HttpUrl ——网页地址

[1]

‘==================================================

Function GetHttpPage(HttpUrl)

If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl=”$False$” Then

GetHttpPage=”$False$”

Exit Function

End If

Dim Http

Set Http=server.createobject(“MSXML2.XMLHTTP”)

Http.open “GET”,HttpUrl,False

Http.Send()

If Http.Readystate<>4 then

Set Http=Nothing

GetHttpPage=”$False$”

Exit function

End if

GetHTTPPage=bytesToBSTR(Http.responseBody,”GB2312″)

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

‘==================================================

‘函数名: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(Byval 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

TempStr=Replace(TempStr,””””,””)

TempStr=Replace(TempStr,”‘”,””)

TempStr=Replace(TempStr,” “,””)

TempStr=Replace(TempStr,”(“,””)

TempStr=Replace(TempStr,”)”,””)

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,strInstallDir,strChannelDir,SaveTf,TistUrl)

If ConStr=”$False$” or ConStr=”” or strInstallDir=”” 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 =”]>”

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
=”srcs*=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 =”srcs*=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= strChannelDir & “/” & year(DtNow) & right(“0” &
month(DtNow),2) & “/”

   response.write “链接路径:” & savepath & “

Arr_Path=Split(SavePath,”/”)

PathTemp=””

For Tempi=0 To Ubound(Arr_Path)

If Tempi=0 Then

PathTemp=Arr_Path(0) & “/”

ElseIf Tempi=Ubound(Arr_Path) Then

Exit For

Else

PathTemp=PathTemp & Arr_Path(Tempi) & “/”

End If

If CheckDir(PathTemp)=False Then

If MakeNewsDir(PathTemp)=False Then

SaveTf=False

Exit For

End If

End If

Next

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$”)

‘去掉重复图片结束

‘转换相对图片地址开始

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)

RemoteFileUrl=TempArray2(Tempi)

If RemoteFileUrl<>”$False$” And SaveTf=True Then’保存图片

ArrSaveFileName = Split(RemoteFileurl,”.”)

   strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))’文件类型

If strFileType=”asp” or strFileType=”asa” or strFileType=”aspx” or
strFileType=”cer” or strFileType=”cdx” or strFileType=”exe” or
strFileType=”rar” or strFileType=”zip” then

UploadFiles=””

ReplaceSaveRemoteFile=ConStr

Exit Function

End If

Randomize

RanNum=Int(900*Rnd)+100

   strFileName = year(DtNow) & right(“0” & month(DtNow),2) & right(“0” &
day(DtNow),2) & right(“0” & hour(DtNow),2) & right(“0” &
minute(DtNow),2) & right(“0” & second(DtNow),2) & ranNum & “.” &
strFileType

Re.Pattern =TempArray(Tempi)

   If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then

‘********************************

PathTemp=SavePath & strFileName

ConStr=Re.Replace(ConStr,PathTemp)

Re.Pattern=strInstallDir & strChannelDir & “/”

UploadFiles=UploadFiles & “|” & Re.Replace(SavePath &strFileName,””)

Else

PathTemp=RemoteFileUrl

ConStr=Re.Replace(ConStr,PathTemp)

‘UploadFiles=UploadFiles & “|” & RemoteFileUrl

End If

ElseIf RemoteFileurl<>”$False$” and SaveTf=False Then’不保存图片

Re.Pattern =TempArray(Tempi)

ConStr=Re.Replace(ConStr,RemoteFileUrl)

UploadFiles=UploadFiles & “|” & RemoteFileUrl

End If

Next

Set Re=nothing

If UploadFiles<>”” Then

UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)

End If

ReplaceSaveRemoteFile=ConStr

End function

‘==================================================

‘函数名:ReplaceSwfFile

‘作 用:解析动画路径

‘参 数:ConStr —— 要替换的字符串

‘参 数: TistUrl—— 当前网页地址

‘==================================================

Function ReplaceSwfFile(ConStr,TistUrl)

If ConStr=”$False$” or ConStr=”” or TistUrl=”” or TistUrl=”$False$” Then

ReplaceSwfFile=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 =”]>”

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 =”values*=s*.+?.swf”

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 =”values*=s*”

TempStr=Re.Replace(TempStr,””)

End If

If TempStr=”” or IsNull(TempStr)=True Then

ReplaceSwfFile=ConStr

Exit function

End if

TempStr=Replace(TempStr,””””,””)

TempStr=Replace(TempStr,”‘”,””)

TempStr=Replace(TempStr,” “,””)

Set Matches=nothing

Set Re=nothing

‘去掉重复文件开始

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$”)

‘去掉重复文件结束

‘转换相对地址开始

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)

RemoteFileUrl=TempArray2(Tempi)

Re.Pattern =TempArray(Tempi)

ConStr=Re.Replace(ConStr,RemoteFileUrl)

Next

Set Re=nothing

ReplaceSwfFile=ConStr

End function

‘==================================================

‘过程名:SaveRemoteFile

‘作 用:保存远程的文件到本地

‘参 数:LocalFileName —— 本地文件名

‘参 数:RemoteFileUrl —— 远程文件URL

‘==================================================

Function SaveRemoteFile(LocalFileName,RemoteFileUrl)

SaveRemoteFile=True

  dim Ads,Retrieval,GetRemoteData

  Set Retrieval = Server.CreateObject(“Microsoft.XMLHTTP”)

  With Retrieval

    .Open “Get”, RemoteFileUrl, False, “”, “”

    .Send

If .Readystate<>4 then

SaveRemoteFile=False

Exit Function

End If

    GetRemoteData = .ResponseBody

  End With

  Set Retrieval = Nothing

  Set Ads = Server.CreateObject(“Adodb.Stream”)

  With Ads

    .Type = 1

    .Open

    .Write GetRemoteData

    .SaveToFile server.MapPath(LocalFileName),2

    .Cancel()

    .Close()

  End With

  Set Ads=nothing

end Function

‘==================================================

‘函数名:FpHtmlEnCode

‘作 用:标题过滤

‘参 数:fString ——字符串

‘==================================================

Function FpHtmlEnCode(fString)

If IsNull(fString)=False or fString<>”” or
fString<>”$False$” Then

fString=nohtml(fString)

fString=FilterJS(fString)

fString = Replace(fString,” “,” “)

fString = Replace(fString,”””,””)

fString = Replace(fString,”‘”,””)

fString = replace(fString, “>”, “”)

fString = replace(fString, “<“, “”)

fString = Replace(fString, CHR(9), ” “)’ 

fString = Replace(fString, CHR(10), “”)

fString = Replace(fString, CHR(13), “”)

fString = Replace(fString, CHR(34), “”)

fString = Replace(fString, CHR(32), ” “) ‘space

fString = Replace(fString, CHR(39), “”)

fString = Replace(fString, CHR(10) & CHR(10),””)

fString = Replace(fString, CHR(10)&CHR(13), “”)

fString=Trim(fString)

FpHtmlEnCode=fString

Else

FpHtmlEnCode=”$False$”

End If

End Function

You can leave a response, or trackback from your own site.

Leave a Reply

网站地图xml地图