📄 ks_collectcommoncls.asp
字号:
'==================================================
'函数名：PostHttpPage
'作 用：登录
'==================================================
Function PostHttpPage(RefererUrl, PostUrl, PostData)
Dim xmlHttp
Dim RetStr
Set xmlHttp = CreateObject("Msxml2.XMLHTTP")
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 = "Error"
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 = "Error" Or Constr = "" Or IsNull(Constr) = True Or StartStr = "" Or IsNull(StartStr) = True Or OverStr = "" Or IsNull(OverStr) = True Then
GetBody = "Error"
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 = "Error"
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 = "Error"
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 = "Error" Or Constr = "" Or IsNull(Constr) = True Or StartStr = "" Or OverStr = "" Or IsNull(StartStr) = True Or IsNull(OverStr) = True Then
GetArray = "Error"
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 = "Error"
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 = "Error"
Else
GetArray = TempStr
End If
End Function
'==================================================
'函数名：DefiniteUrl
'作 用：将相对地址转换为绝对地址
'参 数：PrimitiveUrlStr ------要转换的相对地址
'参 数：ConsultUrlStr ------当前网页地址
'==================================================
'Function DefiniteUrl(ByVal PrimitiveUrlStr, ByVal ConsultUrlStr)
Function DefiniteUrl(PrimitiveUrl, ConsultUrl)
Dim ConTemp, PriTemp, Pi, Ci, PriArray, ConArray
Dim PrimitiveUrlStr, ConsultUrlStr
PrimitiveUrlStr = PrimitiveUrl
ConsultUrlStr = ConsultUrl
If PrimitiveUrlStr = "" Or ConsultUrlStr = "" Or PrimitiveUrlStr = "Error" Or ConsultUrlStr = "Error" Then
DefiniteUrl = "Error"
Exit Function
End If
If Left(LCase(ConsultUrlStr), 7) <> "http://" Then
ConsultUrlStr = "http://" & ConsultUrlStr
End If
ConsultUrlStr = Replace(ConsultUrlStr, "\", "/")
ConsultUrlStr = Replace(ConsultUrlStr, "://", ":\\")
PrimitiveUrlStr = Replace(PrimitiveUrlStr, "\", "/")
If Right(ConsultUrlStr, 1) <> "/" Then
If InStr(ConsultUrlStr, "/") > 0 Then
If InStr(Right(ConsultUrlStr, Len(ConsultUrlStr) - InStrRev(ConsultUrlStr, "/")), ".") > 0 Then
Else
ConsultUrlStr = ConsultUrlStr & "/"
End If
Else
ConsultUrlStr = ConsultUrlStr & "/"
End If
End If
ConArray = Split(ConsultUrlStr, "/")
If Left(LCase(PrimitiveUrlStr), 7) = "http://" Then
DefiniteUrl = Replace(PrimitiveUrlStr, "://", ":\\")
ElseIf Left(PrimitiveUrlStr, 1) = "/" Then
DefiniteUrl = ConArray(0) & PrimitiveUrlStr
ElseIf Left(PrimitiveUrlStr, 2) = "./" Then
PrimitiveUrlStr = Right(PrimitiveUrlStr, Len(PrimitiveUrlStr) - 2)
If Right(ConsultUrlStr, 1) = "/" Then
DefiniteUrl = ConsultUrlStr & PrimitiveUrlStr
Else
DefiniteUrl = Left(ConsultUrlStr, InStrRev(ConsultUrlStr, "/")) & PrimitiveUrlStr
End If
ElseIf Left(PrimitiveUrlStr, 3) = "../" Then
Do While Left(PrimitiveUrlStr, 3) = "../"
PrimitiveUrlStr = Right(PrimitiveUrlStr, Len(PrimitiveUrlStr) - 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 & "/" & PrimitiveUrlStr
Else
If InStr(PrimitiveUrlStr, "/") > 0 Then
PriArray = Split(PrimitiveUrlStr, "/")
If InStr(PriArray(0), ".") > 0 Then
If Right(PrimitiveUrlStr, 1) = "/" Then
DefiniteUrl = "http:\\" & PrimitiveUrlStr
Else
If InStr(PriArray(UBound(PriArray) - 1), ".") > 0 Then
DefiniteUrl = "http:\\" & PrimitiveUrlStr
Else
DefiniteUrl = "http:\\" & PrimitiveUrlStr & "/"
End If
End If
Else
If Right(ConsultUrlStr, 1) = "/" Then
DefiniteUrl = ConsultUrlStr & PrimitiveUrlStr
Else
DefiniteUrl = Left(ConsultUrlStr, InStrRev(ConsultUrlStr, "/")) & PrimitiveUrlStr
End If
End If
Else
If InStr(PrimitiveUrlStr, ".") > 0 Then
If Right(ConsultUrlStr, 1) = "/" Then
If Right(LCase(PrimitiveUrlStr), 3) = ".cn" Or Right(LCase(PrimitiveUrlStr), 3) = "com" Or Right(LCase(PrimitiveUrlStr), 3) = "net" Or Right(LCase(PrimitiveUrlStr), 3) = "org" Then
DefiniteUrl = "http:\\" & PrimitiveUrlStr & "/"
Else
DefiniteUrl = ConsultUrlStr & PrimitiveUrlStr
End If
Else
If Right(LCase(PrimitiveUrlStr), 3) = ".cn" Or Right(LCase(PrimitiveUrlStr), 3) = "com" Or Right(LCase(PrimitiveUrlStr), 3) = "net" Or Right(LCase(PrimitiveUrlStr), 3) = "org" Then
DefiniteUrl = "http:\\" & PrimitiveUrlStr & "/"
Else
DefiniteUrl = Left(ConsultUrlStr, InStrRev(ConsultUrlStr, "/")) & "/" & PrimitiveUrlStr
End If
End If
Else
If Right(ConsultUrlStr, 1) = "/" Then
DefiniteUrl = ConsultUrlStr & PrimitiveUrlStr & "/"
Else
DefiniteUrl = Left(ConsultUrlStr, InStrRev(ConsultUrlStr, "/")) & "/" & PrimitiveUrlStr & "/"
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 = "Error"
End If
'我加进去的
If CheckTheChar("http://", DefiniteUrl) > 1 Then
DefiniteUrl = "http://" & Replace(DefiniteUrl, "http://", "")
End If
End Function
'==================================================
'函数名：ReplaceSaveRemoteFile
'作 用：替换、保存远程图片
'参 数：ConStr ------ 要替换的字符串
'参 数：SaveTf ------ 是否保存文件，False不保存，True保存
'参 数: TistUrl------ 当前网页地址
'==================================================
Function ReplaceSaveRemoteFile(UploadFiles, Constr, strInstallDir, strChannelDir, SaveTf, TistUrl)
If Constr = "Error" 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 = "<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= strChannelDir & "/" & year(DtNow) & right("0" & month(DtNow),2) & "/"
If KSCMS.GetConfig("SaveImgByDate") = 1 Then
SavePath = "/" & KSCMS.GetConfig("BeyondPicDir") & Year(Now()) & "-" & Right("0" & Month(Now()), 2) & "/"
Else
SavePath = "/" & KSCMS.GetConfig("BeyondPicDir")
End If
'Response.Write "链接路径：" & savepath & "<br>"
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)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -