📄 cl_clscollect.asp
字号:
'作 用：格式化成当前网站完整的URL-将相对地址转换为绝对地址
'参 数： url ----Url字符串
'参 数： CurrentUrl ----当然网站URL
'返回值：格式化取后的Url
'===============================================
Public Function FormatRemoteUrl(ByVal URL,ByVal CurrentUrl)
Dim strUrl
If Len(URL) < 2 Or Len(URL) > 255 Or Len(CurrentUrl) < 2 Then
FormatRemoteUrl = vbNullString
Exit Function
End If
CurrentUrl = Trim(Replace(Replace(Replace(Replace(Replace(CurrentUrl, "'", vbNullString), """", vbNullString), vbNewLine, vbNullString), "\", "/"), "|", vbNullString))
URL = Trim(Replace(Replace(Replace(Replace(Replace(URL, "'", vbNullString), """", vbNullString), vbNewLine, vbNullString), "\", "/"), "|", vbNullString))
If InStr(9, CurrentUrl, "/") = 0 Then
strUrl = CurrentUrl
Else
strUrl = Left(CurrentUrl, InStr(9, CurrentUrl, "/") - 1)
End If
If strUrl = vbNullString Then strUrl = CurrentUrl
Select Case Left(LCase(URL), 6)
Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
FormatRemoteUrl = URL
Exit Function
End Select
If Left(URL, 1) = "/" Then
FormatRemoteUrl = strUrl & URL
Exit Function
End If
If Left(URL, 3) = "../" Then
Dim ArrayUrl
Dim ArrayCurrentUrl
Dim ArrayTemp()
Dim strTemp
Dim i, n
Dim c, l
n = 0
ArrayCurrentUrl = Split(CurrentUrl, "/")
ArrayUrl = Split(URL, "../")
c = UBound(ArrayCurrentUrl)
l = UBound(ArrayUrl) + 1
If c > l + 2 Then
For i = 0 To c - l
ReDim Preserve ArrayTemp(n)
ArrayTemp(n) = ArrayCurrentUrl(i)
n = n + 1
Next
strTemp = Join(ArrayTemp, "/")
Else
strTemp = strUrl
End If
URL = Replace(URL, "../", vbNullString)
FormatRemoteUrl = strTemp & "/" & URL
Exit Function
End If
strUrl = Left(CurrentUrl, InStrRev(CurrentUrl, "/"))
FormatRemoteUrl = strUrl & Replace(URL, "./", vbNullString)
Exit Function
End Function
'===============================================
'函数名：ReplaceTrim
'作 用：过滤掉字符中所有的tab和回车和换行
'===============================================
Public Function ReplaceTrim(ByVal strContent)
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(" & Chr(8) & "|" & Chr(9) & "|" & Chr(10) & "|" & Chr(13) & ")"
strContent = re.Replace(strContent, vbNullString)
Set re = Nothing
ReplaceTrim = strContent
Exit Function
End Function
'===============================================
'函数名：ItemReplaceStr
'作 用：项目内容字符替换
'===============================================
Public Function ItemReplaceStr(ByVal strContent,ByVal ReplaceList)
If ReplaceList="" then ItemReplaceStr=strContent : Exit Function
If Len(ReplaceList) < 3 Or Len(strContent) = 0 Then Exit Function
Dim i,ReplaceListArray,ReplaceNameArray
On Error Resume Next
ReplaceListArray = Split(ReplaceList, "$$$")
For i = 0 To UBound(ReplaceListArray)
If Len(ReplaceListArray(i)) > 2 Then
ReplaceNameArray = Split(ReplaceListArray(i), "|")
strContent = Replace(strContent, ReplaceNameArray(0), ReplaceNameArray(1))
End If
Next
ItemReplaceStr = strContent
End Function
'===============================================
'返回值：返回采集菜单
'作 用：读取采集菜单
'===============================================
Function CjMenu()
Dim RS,TempStr
Set Rs=Conn_C.execute("select * from ModuleInfo where Flag=1 order by ID ASC")
If Not Rs.eof then
While not Rs.eof
TempStr=TempStr & "<TR>" & vbcrlf
TempStr=TempStr & " <TD height=30 align=""center"" background=""images/left_bg01.gif"" id=""CjMenu"" style=""cursor:hand"" onClick=""javascript:parent.main.location.href='"& Rs("FileName") &"?ModuleID="&Rs("ID")&"';"" onMouseOver=""leftBgOver(this);"" onMouseOut=""leftBgOut(this,'images/left_bg01.gif');"">"& Rs("CjName") &"采集</TD>" & vbcrlf
TempStr=TempStr & "</TR>" & vbcrlf
Rs.Movenext
Wend
End if : Rs.close : Set Rs=Nothing
CjMenu=TempStr
End Function
'===============================================
'函数名：Show_Top()
'作 用：头部。
'===============================================
Sub Show_Top()
Dim CJFileName : CJFileName = GetItemConfig("FileName",ModuleID)
header
Response.Write "<table width=""100%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""Border"">" & vbcrlf
Response.Write " <tr> " & vbcrlf
Response.Write " <td height=""22"" colspan=""2"" align=""center"" class=""title""><strong>"&CjName&"采集管理</td>" & vbcrlf
Response.Write " </tr>" & vbcrlf
Response.Write " <tr class=""tdbg"">" & vbcrlf
Response.Write " <td width=""70"" height=""30""><strong>操作导航：</strong></td>" & vbcrlf
Response.Write " <td><a href="& CJFileName &">管理首页</a> | <a href="""& CJFileName &"?action=add&ModuleID="& ModuleID &""">添加新项目</a> | <a href='"& CJFileName &"?action=config&ChannelID=0'>采集基本设置</a></td>" & vbcrlf
Response.Write " </tr>" & vbcrlf
Response.Write "</table>" & vbcrlf
Response.Write "<br/>" & vbcrlf
End Sub
Function GetStars(Stars_Str)
Select Case Stars_Str
case 1
GetStars="★"
case 2
GetStars="★★"
case 3
GetStars="★★★"
case 4
GetStars="★★★★"
case 5
GetStars="★★★★★"
end select
end Function
Function CheckRepeat(strUrl)'历史记录
CheckRepeat=False
If IsArray(Arr_Histrolys)=True then
For His_i=0 to Ubound(Arr_Histrolys,2)
If Arr_Histrolys(0,His_i)=strUrl Then
CheckRepeat=True
His_Title=Arr_Histrolys(1,His_i)
His_CollecDate=Arr_Histrolys(2,His_i)
His_Result=Arr_Histrolys(3,His_i)
Exit For
End If
Next
End If
End Function
Public Function IsExpired(strClassString)
On Error Resume Next
IsExpired = True
Err = 0
Dim xTestObj:Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then
Select Case strClassString
Case "Persits.Jpeg"
If xTestObjResponse.Expires > Now Then
IsExpired = False
End If
Case "wsImage.Resize"
If InStr(xTestObj.errorinfo, "已经过期") = 0 Then
IsExpired = False
End If
Case "SoftArtisans.ImageGen"
xTestObj.CreateImage 500, 500, RGB(255, 255, 255)
If Err = 0 Then
IsExpired = False
End If
End Select
End If
Set xTestObj = Nothing
Err = 0
End Function
End Class
'------------------------水印类--------------------------
Class Cls_Thumb
'为图片添加水印
Function AddWaterMark(FileName)
Dim objFileSystem,strFileExtName,objImage
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
If FileName <> "" And Not IsNull(FileName) Then
strFileExtName = ""
If InStr(FileName, ".") <> 0 Then
strFileExtName = LCase(Trim(Mid(FileName, InStrRev(FileName, ".") + 1)))
End If
If strFileExtName <> "jpg" And strFileExtName <> "gif" And strFileExtName <> "bmp" And strFileExtName <> "png" Then
Exit Function
End If
Set objFileSystem = Server.CreateObject(Trim(Cl.Web_Info(13)))
If objFileSystem.FileExists(FileName) Then
If Cl.Upload_Setting(2) <> "0" Then
Select Case Cl.Upload_Setting(2)
'Case "0"
' If Cl.ChkObjInstalled("CreatePreviewImage.cGvbox") Then
' If CGet.IsExpired("CreatePreviewImage.cGvbox") Then
' Response.Write ("对不起，CreatePreviewImage.cGvbox组件已过期!")
' Response.End
' End If
' If Cl.Upload_Setting(3) = "1" Then
' AddWordMark 2, Cl.Upload_Setting(4), Cl.Upload_Setting(6), Cl.Upload_Setting(7), Cl.Upload_Setting(8), Cl.Upload_Setting(5), Cl.Upload_Setting(14), FileName
' Else
' AddPhotoMark 2, Cl.Upload_Setting(12), Cl.Upload_Setting(13), Cl.Upload_Setting(9), Cl.Upload_Setting(10), Cl.Upload_Setting(11), Cl.Upload_Setting(14), FileName
' End If
' End If
Case "1"
If Cl.ChkObjInstalled("Persits.Jpeg") Then
If CGet.IsExpired("Persits.Jpeg") Then
Response.Write ("对不起，Persits.Jpeg组件已过期!")
Response.End
End If
If Cl.Upload_Setting(3) = "1" Then
AddWordMark 1, Cl.Upload_Setting(4), Cl.Upload_Setting(6), Cl.Upload_Setting(7), Cl.Upload_Setting(8), Cl.Upload_Setting(5), Cl.Upload_Setting(14), FileName
Else
AddPhotoMark 1, Cl.Upload_Setting(12), Cl.Upload_Setting(13), Cl.Upload_Setting(9), Cl.Upload_Setting(10), Cl.Upload_Setting(11), Cl.Upload_Setting(14), FileName
End If
End If
Case "2"
If Cl.ChkObjInstalled("SoftArtisans.ImageGen") Then
If CGet.IsExpired("SoftArtisans.ImageGen") Then
Response.Write ("对不起，SoftArtisans.ImageGen组件已过期!")
Response.End
End If
If Cl.Upload_Setting(3) = "1" Then
AddWordMark 3, Cl.Upload_Setting(4), Cl.Upload_Setting(6), Cl.Upload_Setting(7), Cl.Upload_Setting(8), Cl.Upload_Setting(5), Cl.Upload_Setting(14), FileName
Else
AddPhotoMark 3, Cl.Upload_Setting(12), Cl.Upload_Setting(13), Cl.Upload_Setting(9), Cl.Upload_Setting(10), Cl.Upload_Setting(11), Cl.Upload_Setting(14), FileName
End If
End If
'Case "3"
' If Cl.ChkObjInstalled("sjCatSoft.Thumbnail") Then
' If CGet.IsExpired("sjCatSoft.Thumbnail") Then
' Response.Write ("对不起，sjCatSoft.Thumbnail组件已过期!")
' Response.End
' End If
' If Cl.Upload_Setting(3) = "1" Then
' AddWordMark 2, Cl.Upload_Setting(4), Cl.Upload_Setting(6), Cl.Upload_Setting(7), Cl.Upload_Setting(8), Cl.Upload_Setting(5), Cl.Upload_Setting(14), FileName
' Else
' AddPhotoMark 2, Cl.Upload_Setting(12), Cl.Upload_Setting(13), Cl.Upload_Setting(9), Cl.Upload_Setting(10), Cl.Upload_Setting(11), Cl.Upload_Setting(14), FileName
' End If
' End If
End Select
End If
End If
Set objFileSystem = Nothing
End If
End Function
'为图片添加文字水印函数
Function AddWordMark(MarkComponentID, MarkText, MarkFontColor, MarkFontName, MarkFontBond, MarkFontSize, MarkPosition, FileName)
Dim objImage, x, y, Text, TextWidth, FontColor, FontName, FondBond, FontSize, OriginalWidth, OriginalHeight
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
Text = Trim(MarkText)
If Text = "" Then
Exit Function
End If
FontColor = Replace(MarkFontColor, "#", "&H")
FontName = MarkFontName
If MarkFontBond = "1" Then
FondBond = True
Else
FondBond = False
End If
FontSize = CInt(MarkFontSize)
Select Case MarkComponentID
Case 1
If Not Cl.ChkObjInstalled("Persits.Jpeg") Then
Exit Function
End If
Set objImage = Server.CreateObject("Persits.Jpeg")
objImage.Open FileName
objImage.Canvas.Font.Color = FontColor
objImage.Canvas.Font.Family = FontName
objImage.Canvas.Font.Bold = FondBond
objImage.Canvas.Font.size = FontSize
TextWidth = objImage.Canvas.GetTextExtent(Text)
If objImage.OriginalWidth < TextWidth Or objImage.OriginalHeight < FontSize Then
Exit Function
End If
GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, TextWidth, FontSize
With objImage.Canvas
.Print x, y, Text
End With
objImage.Save FileName
Case 2
If Not Cl.ChkObjInstalled("SoftArtisans.ImageGen") Then
Exit Function
End If
Set objImage = Server.CreateObject("SoftArtisans.ImageGen")
objImage.LoadImage FileName
objImage.Font.Height = FontSize
objImage.Font.name = FontName
FontColor = "&H" & Mid(FontColor, 7) & Mid(FontColor, 5, 2) & Mid(FontColor, 3, 2)
objImage.Font.Color = CLng(FontColor)
objImage.Text = Text
GetPostion CInt(MarkPosition), x, y, objImage.Width, objImage.Height, objImage.TextWidth, objImage.TextHeight
objImage.DrawTextOnImage x, y, objImage.TextWidth, objImage.TextHeight
objImage.SaveImage 0, objImage.ImageFormat, FileName
'Case 3
' If Not Cl.ChkObjInstalled("wsImage.Resize") Then
' Exit Function
' End If
' Set objImage = Server.CreateObject("wsImage.Resize")
' objImage.LoadSoucePic CStr(FileName)
' objImage.TxtMarkFont = CStr(FontName)
' objImage.TxtMarkBond = FondBond
' objImage.TxtMarkHeight = FontSize
' FontColor = "&H" & Mid(FontColor, 7) & Mid(FontColor, 5, 2) & Mid(FontColor, 3, 2)
' objImage.AddTxtMark CStr(FileName), CStr(Text), CLng(FontColor), 1, 1
End Select
Set objImage = Nothing
End Function
Function AddPhotoMark(MarkComponentID, MarkWidth, MarkHeight, MarkPicture, MarkOpacity, MarkTranspColor, MarkPosition, FileName)
Dim objImage, objMark, x, y, OriginalWidth, OriginalHeight, Position
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
If IsNull(MarkWidth) Or MarkWidth = "" Then
MarkWidth = 0
Else
MarkWidth = CInt(MarkWidth)
End If
If IsNull(MarkHeight) Or MarkHeight = "" Then
MarkHeight = 0
Else
MarkHeight = CInt(MarkHeight)
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -