?? 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 + -