📄 sk_funcls.asp
字号:
SaveRemoteFile=True
dim Ads,Retrieval,GetRemoteData
On Error Resume Next
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
.Send
If .Readystate<>4 or .Status > 300 then
SaveRemoteFile=False
Exit Function
End If
GetRemoteData = .ResponseBody
End With
Set Retrieval = Nothing
If MaxFileSize > 0 Then
If LenB(GetRemoteData) > MaxFileSize Then Exit Function
End If
Response.Write(Round(LenB(GetRemoteData)/1024)) & "KB"
Set Ads = Server.CreateObject("Adodb.Stream")
With Ads
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile server.MapPath(LocalFileName),2
.Cancel()
.Close()
End With
If Err.number<>0 then
SaveRemoteFile=False
Exit Function
Err.Clear
End If
Set Ads=nothing
end Function
'===============================================
'函数名：Sk_GetSaveDir()
'lx=类型
'作 用：读取文件保存目录设置
'===============================================
Function Sk_GetSaveDir(lx)
Dim strInstallDir,CacheTemp,rs,strtemp,strChannelDir,Arr_Path,Tempi,PathTemp,SaveTf,TempUrlArray,Ranfilestr
strInstallDir=trim(request.ServerVariables("SCRIPT_NAME"))
strInstallDir=left(strInstallDir,instrrev(lcase(strInstallDir),"/")-1)
set rs = ConnItem.execute("Select top 1 Dir,MaxFileSize,FileExtName,Timeout from SK_Cj where ID=" & lx)
strtemp = strtemp & rs("Dir")
Sk_GetSaveDir = strtemp & SaveFileUrl
rs.close
set rs=nothing
end function
'===============================================
'函数名：Sk_SaveFile()
'参 数: Lx=频道
'参 数: FileUrl=远程文件地址
'作 用：按频道功能保存远程文件替换地址
'===============================================
Function Sk_SaveFile(Lx,FileUrl)
Dim strInstallDir,CacheTemp,rs,strtemp,strChannelDir,Arr_Path,Tempi,PathTemp,SaveTf,TempUrlArray,Ranfilestr,Ranfilestr1
Dim SqlTemp
FileUrl=replace(replace(FileUrl,"""","")," ","")
SqlTemp="Select top 1 Dir,MaxFileSize from SK_Cj where ID="& Lx
set rs = ConnItem.execute(SqlTemp)
strtemp = rs("Dir") & SaveFileUrl
Arr_Path=Split(strtemp,"/")
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
TempUrlArray=Split(FileUrl,"/")
Ranfilestr=GetFileID(strtemp,TempUrlArray(Ubound(TempUrlArray)),3)'生成文件名
'Call SaveRemoteFile(Ranfilestr,FileUrl)'保存远程文件
If SaveRemoteFile(Ranfilestr,FileUrl)<>False then'保存远程文件
Ranfilestr1=Ranfilestr
if Thumb_WaterMark=1 And Lx=2 then call SKThumb.AddWaterMark(Ranfilestr)'水印
Sk_SaveFile = Ranfilestr1
Else
Sk_SaveFile = False
End if
rs.close
Set rs=nothing
End function
Private Function CorrectPattern(ByVal str)
str = Replace(str, "\", "\\")
str = Replace(str, "~", "\~")
str = Replace(str, "!", "\!")
str = Replace(str, "@", "\@")
str = Replace(str, "#", "\#")
str = Replace(str, "%", "\%")
str = Replace(str, "^", "\^")
str = Replace(str, "&", "\&")
str = Replace(str, "*", "\*")
str = Replace(str, "(", "\(")
str = Replace(str, ")", "\)")
str = Replace(str, "-", "\-")
str = Replace(str, "+", "\+")
str = Replace(str, "[", "\[")
str = Replace(str, "]", "\]")
str = Replace(str, "<", "\<")
str = Replace(str, ">", "\>")
str = Replace(str, ".", "\.")
str = Replace(str, "/", "\/")
str = Replace(str, "?", "\?")
str = Replace(str, "=", "\=")
str = Replace(str, "|", "\|")
str = Replace(str, "$", "\$")
CorrectPattern = str
End Function
'===============================================
'函数名：FormatRemoteUrl
'作 用：格式化成当前网站完整的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=ConnItem.execute("select * from SK_cj 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") &"?Colleclx="&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",Colleclx)
Response.Write "<html>" & vbcrlf
Response.Write "<head>" & vbcrlf
Response.Write "<title>清风信息自动采集生成系统</title>" & vbcrlf
Response.Write "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">" & vbcrlf
Response.Write "<link rel=""stylesheet"" type=""text/css"" href=""css/Admin_Style.css""></head>" & vbcrlf
Response.Write "<script src=""Inc/Common.JS"" language=""javascript""></script>" & vbcrlf
Response.Write "<body leftmargin=""0"" topmargin=""0"" marginwidth=""0"" marginheight=""0"">" & vbcrlf
Response.Write "<table width=""100%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""tableBorder"">" & vbcrlf
Response.Write " <tr> " & vbcrlf
Response.Write " <td height=""22"" colspan=""2"" align=""center"" bgcolor=""#F3F3F3"" class=""topbg""><strong>"&CjName&"采集管理</td>" & vbcrlf
Response.Write " </tr>" & vbcrlf
Response.Write "</table>" & vbcrlf
Response.Write "<table width=""100%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""1"" class=""tableBorder"">" & vbcrlf
Response.Write " <tr class=""tdbg"">" & vbcrlf
Response.Write " <td height=""30"" colspan=""3"" bgcolor=""f3f3f3""><b>说明：</b><br> ①、第一次使用本功能，请修改<a href='"& CJFileName &"?action=config'><font color=blue>采集基本设置</font></a>；<br>" & vbcrlf
Response.Write " ②、采集前请<font color=blue>编辑</font>采集项目，<font color=blue>测试</font>项目确定无误后再进行采集。 </td> " & vbcrlf
Response.Write " </tr> " & vbcrlf
Response.Write " <tr class=""tdbg"">" & vbcrlf
Response.Write " <td width=""79"" height=""30"" bgcolor=""f3f3f3""><strong>操作导航：</strong></td>" & vbcrlf
Response.Write " <td width=""600"" bgcolor=""f3f3f3""><a href="& CJFileName &">管理首页</a> | <a href="""& CJFileName &"?action=add&Colleclx="& Colleclx &""">添加新项目</a> | <a href='"& CJFileName &"?action=config&ChannelID=0'>采集基本设置</a> | <a href=""sk_class.asp?Colleclx="& Colleclx &""">分类设置 </a> </td>" & vbcrlf
Response.Write " <form name=""form1"" id=""form1""><td width=""200"" height=""30"" bgcolor=""f3f3f3"">分类显示：<Select ID=""DClassID"" name=""DClassID"" onchange=""MM_jumpMenu('this',this,0)"">"
Call Showclass_d(ClassID,Colleclx)
Response.Write "</Select></td></form>" & vbcrlf
Response.Write " </tr>" & vbcrlf
Response.Write "</table>" & vbcrlf
End Sub
'==================================================
'过程名：Showclass_d
'作 用：显示频道栏目分类单机版
'==================================================
Sub Showclass_d(ClassID,ChannelID)
Dim CJFileName : CJFileName = GetItemConfig("FileName",Colleclx)
if ChannelID<>0 And ChannelID<>"" then
set Rs=connitem.execute("select * from SK_class where ChannelID="& ChannelID &" order by OrderID")
if rs.eof then
Response.Write "<option value='0'> 你没设分类</option>"
Else
Response.Write "<option value='0'> 选择分类</option>"
Response.Write "<option value='"& CJFileName &"?DclassID=0'> 全部分类</option>"
End if
while not rs.eof
Response.Write "<option value="& CJFileName &"?DclassID="& rs("classid")
if Cstr(rs("classid")) = ClassID then Response.Write " selected"
Response.Write ">"
If Rs("depth") = 1 Then Response.Write " <font color=""#666666"">├</font>"
If Rs("depth") > 1 Then
For i = 2 To Rs("depth")
Response.Write " <font color=""#666666"">│</font>"
Next
Response.Write " <font color=""#666666"">├</font> "
End If
If Rs("depth") = 0 Then Response.Write ("<b>")
Response.Write rs("className")
If Rs("depth") = 0 Then Response.Write ("</b>")
Response.Write "</option>"
rs.movenext
wend
rs.close
set rs=nothing
End if
end sub
End Class
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -