BVB Source Codes

Jie Yang v0.6.3 article system Show Function.asp Source code

Return Download Jie Yang v0.6.3 article system: download Function.asp Source code - Download Jie Yang v0.6.3 article system Source code - Type:.asp
  1. <%
  2. '==================================================
  3. '过程名:Admin_ShowItem_Name
  4. '作  用:显示项目名称
  5. '参  数:ItemID ------项目ID
  6. '==================================================
  7. Sub Admin_ShowItem_Name(ItemID)  
  8.    Dim Sqlc,Rsc,TempStr
  9.    ItemID=Clng(ItemID)
  10.    Sqlc ="select top 1 ItemName from Item Where ItemID=" & ItemID  
  11.    Set Rsc=server.CreateObject("adodb.recordset")  
  12.    Rsc.open Sqlc,ConnItem,1,1  
  13.    If Rsc.Eof and Rsc.Bof then  
  14.       TempStr="无指定项目"  
  15.    Else  
  16.       TempStr=Rsc("ItemName")
  17.    End if  
  18.    Rsc.Close  
  19.    Set Rsc=Nothing
  20.    Response.Write TempStr  
  21. End Sub  
  22.  
  23.  
  24. '==================================================
  25. '过程名:Admin_ShowItem_Option
  26. '作  用:显示项目选项
  27. '参  数:ItemID ------项目ID
  28. '==================================================
  29. Sub Admin_ShowItem_Option(ItemID)  
  30.    Dim SqlI,RsI,TempStr
  31.    ItemID=Clng(ItemID)
  32.    SqlI ="select ItemID,ItemName from Item order by ItemID desc"  
  33.    Set RsI=server.CreateObject("adodb.recordset")  
  34.    RsI.Open SqlI,ConnItem,1,1
  35.    TempStr="<select Name=""ItemID"" ID=""ItemID"">"  
  36.    If RsI.Eof and RsI.Bof Then
  37.       TempStr=TempStr & "<option value=""0"">请添加项目</option>"  
  38.    Else  
  39.       TempStr=TempStr & "<option value=""0"">请选择项目</option>"
  40.       Do while not RsI.Eof  
  41.          TempStr=TempStr & "<option value=" & """" & RsI("ItemID") & """" & ""
  42.          If ItemID=RsI("ItemID") Then
  43.             TempStr=TempStr & " Selected"
  44.          End If
  45.          TempStr=TempStr & ">" & RsI("ItemName")
  46.          TempStr=TempStr & "</option>"  
  47.       RsI.Movenext  
  48.       Loop  
  49.    End if
  50.    RsI.Close  
  51.    Set RsI=Nothing  
  52.    TempStr=TempStr & "</select>"
  53.    Response.Write TempStr  
  54. End sub  
  55.  
  56. '==================================================
  57. '函数名:GetHttpPage
  58. '作  用:获取网页源码
  59. '参  数:HttpUrl ------网页地址
  60. '==================================================
  61. Function GetHttpPage(HttpUrl)
  62.    If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
  63.       GetHttpPage="$False$"
  64.       Exit Function
  65.    End If
  66.    Dim Http
  67.    Set Http=server.createobject("MSXML2.XMLHTTP")
  68.    Http.open "GET",HttpUrl,False
  69.    Http.Send()
  70.    If Http.Readystate<>4 then
  71.       Set Http=Nothing
  72.       GetHttpPage="$False$"
  73.       Exit function
  74.    End if
  75.    GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
  76.    Set Http=Nothing
  77.    If Err.number<>0 then
  78.       Err.Clear
  79.    End If
  80. End Function
  81.  
  82. '==================================================
  83. '函数名:BytesToBstr
  84. '作  用:将获取的源码转换为中文
  85. '参  数:Body ------要转换的变量
  86. '参  数:Cset ------要转换的类型
  87. '==================================================
  88. Function BytesToBstr(Body,Cset)
  89.    Dim Objstream
  90.    Set Objstream = Server.CreateObject("adodb.stream")
  91.    objstream.Type = 1
  92.    objstream.Mode =3
  93.    objstream.Open
  94.    objstream.Write body
  95.    objstream.Position = 0
  96.    objstream.Type = 2
  97.    objstream.Charset = Cset
  98.    BytesToBstr = objstream.ReadText
  99.    objstream.Close
  100.    set objstream = nothing
  101. End Function
  102.  
  103. '==================================================
  104. '函数名:PostHttpPage
  105. '作  用:登录
  106. '==================================================
  107. Function PostHttpPage(RefererUrl,PostUrl,PostData)
  108.     Dim xmlHttp
  109.     Dim RetStr      
  110.     Set xmlHttp = CreateObject("Msxml2.XMLHTTP")  
  111.     xmlHttp.Open "POST", PostUrl, False
  112.     XmlHTTP.setRequestHeader "Content-Length",Len(PostData)
  113.     xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  114.     xmlHttp.setRequestHeader "Referer", RefererUrl
  115.     xmlHttp.Send PostData
  116.     If Err.Number <> 0 Then
  117.         Set xmlHttp=Nothing
  118.         PostHttpPage = "$False$"
  119.         Exit Function
  120.     End If
  121.     PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
  122.     Set xmlHttp = nothing
  123. End Function
  124.  
  125. '==================================================
  126. '函数名:UrlEncoding
  127. '作  用:转换编码
  128. '==================================================
  129. Function UrlEncoding(DataStr)
  130.     Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
  131.     StrReturn = ""
  132.     For Si = 1 To Len(DataStr)
  133.         ThisChr = Mid(DataStr,Si,1)
  134.         If Abs(Asc(ThisChr)) < &HFF Then
  135.             StrReturn = StrReturn & ThisChr
  136.         Else
  137.             InnerCode = Asc(ThisChr)
  138.             If InnerCode < 0 Then
  139.                InnerCode = InnerCode + &H10000
  140.             End If
  141.             Hight8 = (InnerCode  And &HFF00)\ &HFF
  142.             Low8 = InnerCode And &HFF
  143.             StrReturn = StrReturn & "%" & Hex(Hight8) &  "%" & Hex(Low8)
  144.         End If
  145.     Next
  146.     UrlEncoding = StrReturn
  147. End Function
  148.  
  149. '==================================================
  150. '函数名:GetBody
  151. '作  用:截取字符串
  152. '参  数:ConStr ------将要截取的字符串
  153. '参  数:StartStr ------开始字符串
  154. '参  数:OverStr ------结束字符串
  155. '参  数:IncluL ------是否包含StartStr
  156. '参  数:IncluR ------是否包含OverStr
  157. '==================================================
  158. Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
  159.    If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then
  160.       GetBody="$False$"
  161.       Exit Function
  162.    End If
  163.    Dim ConStrTemp
  164.    Dim Start,Over
  165.    ConStrTemp=Lcase(ConStr)
  166.    StartStr=Lcase(StartStr)
  167.    OverStr=Lcase(OverStr)
  168.    Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
  169.    If Start<=0 then
  170.       GetBody="$False$"
  171.       Exit Function
  172.    Else
  173.       If IncluL=False Then
  174.          Start=Start+LenB(StartStr)
  175.       End If
  176.    End If
  177.    Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
  178.    If Over<=0 Or Over<=Start then
  179.       GetBody="$False$"
  180.       Exit Function
  181.    Else
  182.       If IncluR=True Then
  183.          Over=Over+LenB(OverStr)
  184.       End If
  185.    End If
  186.    GetBody=MidB(ConStr,Start,Over-Start)
  187. End Function
  188.  
  189.  
  190. '==================================================
  191. '函数名:GetArray
  192. '作  用:提取链接地址,以$Array$分隔
  193. '参  数:ConStr ------提取地址的原字符
  194. '参  数:StartStr ------开始字符串
  195. '参  数:OverStr ------结束字符串
  196. '参  数:IncluL ------是否包含StartStr
  197. '参  数:IncluR ------是否包含OverStr
  198. '==================================================
  199. Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
  200.    If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or  IsNull(StartStr)=True Or IsNull(OverStr)=True Then
  201.       GetArray="$False$"
  202.       Exit Function
  203.    End If
  204.    Dim TempStr,TempStr2,objRegExp,Matches,Match
  205.    TempStr=""
  206.    Set objRegExp = New Regexp
  207.    objRegExp.IgnoreCase = True
  208.    objRegExp.Global = True
  209.    objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
  210.    Set Matches =objRegExp.Execute(ConStr)
  211.    For Each Match in Matches
  212.       TempStr=TempStr & "$Array$" & Match.Value
  213.    Next
  214.    Set Matches=nothing
  215.  
  216.    If TempStr="" Then
  217.       GetArray="$False$"
  218.       Exit Function
  219.    End If
  220.    TempStr=Right(TempStr,Len(TempStr)-7)
  221.    If IncluL=False then
  222.       objRegExp.Pattern =StartStr
  223.       TempStr=objRegExp.Replace(TempStr,"")
  224.    End if
  225.    If IncluR=False then
  226.       objRegExp.Pattern =OverStr
  227.       TempStr=objRegExp.Replace(TempStr,"")
  228.    End if
  229.    Set objRegExp=nothing
  230.    Set Matches=nothing
  231.    
  232.    TempStr=Replace(TempStr,"""","")
  233.    TempStr=Replace(TempStr,"'","")
  234.    TempStr=Replace(TempStr," ","")
  235.    TempStr=Replace(TempStr,"(","")
  236.    TempStr=Replace(TempStr,")","")
  237.  
  238.    If TempStr="" then
  239.       GetArray="$False$"
  240.    Else
  241.       GetArray=TempStr
  242.    End if
  243. End Function
  244.  
  245.  
  246. '==================================================
  247. '函数名:DefiniteUrl
  248. '作  用:将相对地址转换为绝对地址
  249. '参  数:PrimitiveUrl ------要转换的相对地址
  250. '参  数:ConsultUrl ------当前网页地址
  251. '==================================================
  252. Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
  253.    Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
  254.    If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
  255.       DefiniteUrl="$False$"
  256.       Exit Function
  257.    End If
  258.    If Left(Lcase(ConsultUrl),7)<>"http://" Then
  259.       ConsultUrl= "http://" & ConsultUrl
  260.    End If
  261.    ConsultUrl=Replace(ConsultUrl,"\","/")
  262.    ConsultUrl=Replace(ConsultUrl,"://",":\\")
  263.    PrimitiveUrl=Replace(PrimitiveUrl,"\","/")
  264.  
  265.    If Right(ConsultUrl,1)<>"/" Then
  266.       If Instr(ConsultUrl,"/")>0 Then
  267.          If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then  
  268.          Else
  269.             ConsultUrl=ConsultUrl & "/"
  270.          End If
  271.       Else
  272.          ConsultUrl=ConsultUrl & "/"
  273.       End If
  274.    End If
  275.    ConArray=Split(ConsultUrl,"/")
  276.  
  277.    If Left(LCase(PrimitiveUrl),7) = "http://" then
  278.       DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")
  279.    ElseIf Left(PrimitiveUrl,1) = "/" Then
  280.       DefiniteUrl=ConArray(0) & PrimitiveUrl
  281.    ElseIf Left(PrimitiveUrl,2)="./" Then
  282.       PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
  283.       If Right(ConsultUrl,1)="/" Then  
  284.          DefiniteUrl=ConsultUrl & PrimitiveUrl
  285.       Else
  286.          DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
  287.       End If
  288.    ElseIf Left(PrimitiveUrl,3)="../" then
  289.       Do While Left(PrimitiveUrl,3)="../"
  290.          PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
  291.          Pi=Pi+1
  292.       Loop            
  293.       For Ci=0 to (Ubound(ConArray)-1-Pi)
  294.          If DefiniteUrl<>"" Then
  295.             DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
  296.          Else
  297.             DefiniteUrl=ConArray(Ci)
  298.          End If
  299.       Next
  300.       DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
  301.    Else
  302.       If Instr(PrimitiveUrl,"/")>0 Then
  303.          PriArray=Split(PrimitiveUrl,"/")
  304.          If Instr(PriArray(0),".")>0 Then
  305.             If Right(PrimitiveUrl,1)="/" Then
  306.                DefiniteUrl="http:\\" & PrimitiveUrl
  307.             Else
  308.                If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then
  309.                   DefiniteUrl="http:\\" & PrimitiveUrl
  310.                Else
  311.                   DefiniteUrl="http:\\" & PrimitiveUrl & "/"
  312.                End If
  313.             End If      
  314.          Else
  315.             If Right(ConsultUrl,1)="/" Then  
  316.                DefiniteUrl=ConsultUrl & PrimitiveUrl
  317.             Else
  318.                DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
  319.             End If
  320.          End If
  321.       Else
  322.          If Instr(PrimitiveUrl,".")>0 Then
  323.             If Right(ConsultUrl,1)="/" Then
  324.                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
  325.                   DefiniteUrl="http:\\" & PrimitiveUrl & "/"
  326.                Else
  327.                   DefiniteUrl=ConsultUrl & PrimitiveUrl
  328.                End If
  329.             Else
  330.                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
  331.                   DefiniteUrl="http:\\" & PrimitiveUrl & "/"
  332.                Else
  333.                   DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
  334.                End If
  335.             End If
  336.          Else
  337.             If Right(ConsultUrl,1)="/" Then
  338.                DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
  339.             Else
  340.                DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
  341.             End If        
  342.          End If
  343.       End If
  344.    End If
  345.    If Left(DefiniteUrl,1)="/" then
  346.      DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
  347.    End if
  348.    If DefiniteUrl<>"" Then
  349.       DefiniteUrl=Replace(DefiniteUrl,"//","/")
  350.       DefiniteUrl=Replace(DefiniteUrl,":\\","://")
  351.    Else
  352.       DefiniteUrl="$False$"
  353.    End If
  354. End Function
  355.  
  356. '==================================================
  357. '函数名:ReplaceSaveRemoteFile
  358. '作  用:替换、保存远程图片
  359. '参  数:ConStr ------ 要替换的字符串
  360. '参  数:SaveTf ------ 是否保存文件,False不保存,True保存
  361. '参  数: TistUrl------ 当前网页地址
  362. '==================================================
  363. Function ReplaceSaveRemoteFile(ConStr,strInstallDir,SaveTf,TistUrl)
  364.    If ConStr="$False$" or ConStr="" or strInstallDir=""  Then
  365.       ReplaceSaveRemoteFile=ConStr
  366.       Exit Function
  367.    End If
  368.    Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
  369.  
  370.    Set Re = New Regexp
  371.    Re.IgnoreCase = True
  372.    Re.Global = True
  373.    Re.Pattern ="<img.+?[^\>]>"
  374.    Set Matches =Re.Execute(ConStr)
  375.    For Each Match in Matches
  376.       If TempStr<>"" then
  377.          TempStr=TempStr & "$Array$" & Match.Value
  378.       Else
  379.          TempStr=Match.Value
  380.       End if
  381.    Next
  382.  
  383.    If TempStr<>"" Then
  384.       TempArray=Split(TempStr,"$Array$")
  385.       TempStr=""
  386.       For Tempi=0 To Ubound(TempArray)
  387.          Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
  388.          Set Matches =Re.Execute(TempArray(Tempi))
  389.          For Each Match in Matches
  390.             If TempStr<>"" then
  391.                TempStr=TempStr & "$Array$" & Match.Value
  392.             Else
  393.                TempStr=Match.Value
  394.             End if
  395.          Next
  396.       Next
  397.    End if
  398.  
  399.    If TempStr<>"" Then
  400.       Re.Pattern ="src\s*=\s*"
  401.       TempStr=Re.Replace(TempStr,"")
  402.    End If
  403.    Set Matches=nothing
  404.    Set Re=nothing
  405.    If TempStr="" or IsNull(TempStr)=True Then
  406.       ReplaceSaveRemoteFile=ConStr
  407.       Exit function
  408.    End if
  409.    TempStr=Replace(TempStr,"""","")
  410.    TempStr=Replace(TempStr,"'","")
  411.    TempStr=Replace(TempStr," ","")
  412.  
  413.    Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
  414.    DtNow=Now()
  415.    If SaveTf=True then
  416.  '***********************************
  417.       SavePath= "../../Upfiles/Article/"&Date()&"/"
  418.          
  419.       Arr_Path=Split(SavePath,"/")
  420.       PathTemp=""
  421.       For Tempi=0 To Ubound(Arr_Path)
  422.          If Tempi=0 Then
  423.             PathTemp=Arr_Path(0) & "/"
  424.          ElseIf Tempi=Ubound(Arr_Path) Then
  425.             Exit For
  426.          Else
  427.             PathTemp=PathTemp & Arr_Path(Tempi) & "/"
  428.          End If
  429.          If CheckDir(PathTemp)=False Then
  430.             If MakenewsDir(PathTemp)=False Then
  431.                SaveTf=False
  432.                Exit For
  433.             End If
  434.          End If
  435.       Next
  436.    End If
  437.  
  438.    '去掉重复图片开始
  439.    TempArray=Split(TempStr,"$Array$")
  440.    TempStr=""
  441.    For Tempi=0 To Ubound(TempArray)
  442.       If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
  443.          TempStr=TempStr & "$Array$" & TempArray(Tempi)
  444.       End If
  445.    Next
  446.  
  447.    TempStr=Right(TempStr,Len(TempStr)-7)
  448.    TempArray=Split(TempStr,"$Array$")
  449.    '去掉重复图片结束
  450.  
  451.    '转换相对图片地址开始
  452.    TempStr=""
  453.    For Tempi=0 To Ubound(TempArray)
  454.       TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
  455.    Next
  456.    TempStr=Right(TempStr,Len(TempStr)-7)
  457.    TempStr=Replace(TempStr,Chr(0),"")
  458.    TempArray2=Split(TempStr,"$Array$")
  459.    TempStr=""
  460.    '转换相对图片地址结束
  461.  
  462.    '图片替换/保存
  463.    Set Re = New Regexp
  464.    Re.IgnoreCase = True
  465.    Re.Global = True
  466.  
  467.    For Tempi=0 To Ubound(TempArray2)
  468.       RemoteFileUrl=TempArray2(Tempi)
  469.       If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片
  470.          ArrSaveFileName = Split(RemoteFileurl,".")
  471.          strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
  472.          If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" or strFileType="jsp" then
  473.             UploadFiles=""
  474.             ReplaceSaveRemoteFile=ConStr
  475.             Exit Function
  476.          End If
  477.  
  478.          Randomize
  479.          RanNum=Int(900*Rnd)+100
  480.          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
  481.          Re.Pattern =TempArray(Tempi)
  482.          If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then
  483. '********************************
  484.             PathTemp=SavePath & strFileName
  485.             ConStr=Re.Replace(ConStr,PathTemp)
  486.             Re.Pattern=strInstallDir & strChannelDir & "/"
  487.             UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")
  488.          Else
  489.             PathTemp=RemoteFileUrl
  490.             ConStr=Re.Replace(ConStr,PathTemp)
  491.             'UploadFiles=UploadFiles & "|" & RemoteFileUrl
  492.          End If
  493.       ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
  494.          Re.Pattern =TempArray(Tempi)
  495.          ConStr=Re.Replace(ConStr,RemoteFileUrl)
  496.          UploadFiles=UploadFiles & "|" & RemoteFileUrl
  497.       End If
  498.    Next  
  499.    Set Re=nothing
  500.    If UploadFiles<>"" Then
  501.       UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
  502.    End If
  503.    ReplaceSaveRemoteFile=ConStr
  504. End function
  505.  
  506. '==================================================
  507. '函数名:ReplaceSwfFile
  508. '作  用:解析动画路径
  509. '参  数:ConStr ------ 要替换的字符串
  510. '参  数: TistUrl------ 当前网页地址
  511. '==================================================
  512. Function ReplaceSwfFile(ConStr,TistUrl)
  513.    If ConStr="$False$" or ConStr="" or TistUrl="" or TistUrl="$False$" Then
  514.       ReplaceSwfFile=ConStr
  515.       Exit Function
  516.    End If
  517.    Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
  518.  
  519.    Set Re = New Regexp
  520.    Re.IgnoreCase = True
  521.    Re.Global = True
  522.    Re.Pattern ="<object.+?[^\>]>"
  523.    Set Matches =Re.Execute(ConStr)
  524.    For Each Match in Matches
  525.       If TempStr<>"" then
  526.          TempStr=TempStr & "$Array$" & Match.Value
  527.       Else
  528.          TempStr=Match.Value
  529.       End if
  530.    Next
  531.    If TempStr<>"" Then
  532.       TempArray=Split(TempStr,"$Array$")
  533.       TempStr=""
  534.       For Tempi=0 To Ubound(TempArray)
  535.          Re.Pattern ="value\s*=\s*.+?\.swf"
  536.          Set Matches =Re.Execute(TempArray(Tempi))
  537.          For Each Match in Matches
  538.             If TempStr<>"" then
  539.                TempStr=TempStr & "$Array$" & Match.Value
  540.             Else
  541.                TempStr=Match.Value
  542.             End if
  543.          Next
  544.       Next
  545.    End if
  546.    If TempStr<>"" Then
  547.       Re.Pattern ="value\s*=\s*"
  548.       TempStr=Re.Replace(TempStr,"")
  549.    End If
  550.    If TempStr="" or IsNull(TempStr)=True Then
  551.       ReplaceSwfFile=ConStr
  552.       Exit function
  553.    End if
  554.    TempStr=Replace(TempStr,"""","")
  555.    TempStr=Replace(TempStr,"'","")
  556.    TempStr=Replace(TempStr," ","")
  557.  
  558.    Set Matches=nothing
  559.    Set Re=nothing
  560.  
  561.    '去掉重复文件开始
  562.    TempArray=Split(TempStr,"$Array$")
  563.    TempStr=""
  564.    For Tempi=0 To Ubound(TempArray)
  565.       If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
  566.          TempStr=TempStr & "$Array$" & TempArray(Tempi)
  567.       End If
  568.    Next
  569.    TempStr=Right(TempStr,Len(TempStr)-7)
  570.    TempArray=Split(TempStr,"$Array$")
  571.    '去掉重复文件结束
  572.  
  573.    '转换相对地址开始
  574.    TempStr=""
  575.    For Tempi=0 To Ubound(TempArray)
  576.       TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
  577.    Next
  578.    TempStr=Right(TempStr,Len(TempStr)-7)
  579.    TempStr=Replace(TempStr,Chr(0),"")
  580.    TempArray2=Split(TempStr,"$Array$")
  581.    TempStr=""
  582.    '转换相对地址结束
  583.  
  584.    '替换
  585.    Set Re = New Regexp
  586.    Re.IgnoreCase = True
  587.    Re.Global = True
  588.    For Tempi=0 To Ubound(TempArray2)
  589.       RemoteFileUrl=TempArray2(Tempi)
  590.       Re.Pattern =TempArray(Tempi)
  591.       ConStr=Re.Replace(ConStr,RemoteFileUrl)
  592.    Next  
  593.    Set Re=nothing
  594.    ReplaceSwfFile=ConStr
  595. End function
  596.  
  597. '==================================================
  598. '过程名:SaveRemoteFile
  599. '作  用:保存远程的文件到本地
  600. '参  数:LocalFileName ------ 本地文件名
  601. '参  数:RemoteFileUrl ------ 远程文件URL
  602. '==================================================
  603. Function SaveRemoteFile(LocalFileName,RemoteFileUrl)
  604.     SaveRemoteFile=True
  605.         dim Ads,Retrieval,GetRemoteData
  606.         Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
  607.         With Retrieval
  608.                 .Open "Get", RemoteFileUrl, False, "", ""
  609.                 .Send
  610.         If .Readystate<>4 then
  611.             SaveRemoteFile=False
  612.             Exit Function
  613.         End If
  614.                 GetRemoteData = .ResponseBody
  615.         End With
  616.         Set Retrieval = Nothing
  617.         Set Ads = Server.CreateObject("Adodb.Stream")
  618.         With Ads
  619.                 .Type = 1
  620.                 .Open
  621.                 .Write GetRemoteData
  622.                 .SaveToFile server.MapPath(LocalFileName),2
  623.                 .Cancel()
  624.                 .Close()
  625.         End With
  626.         Set Ads=nothing
  627. end Function
  628.  
  629. '==================================================
  630. '函数名:FpHtmlEnCode
  631. '作  用:标题过滤
  632. '参  数:fString ------字符串
  633. '==================================================
  634. Function FpHtmlEnCode(fString)
  635.    If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
  636.        fString=nohtml(fString)
  637.        fString=FilterJS(fString)
  638.        fString = Replace(fString,"&nbsp;"," ")
  639.        fString = Replace(fString,"&quot;","")
  640.        fString = Replace(fString,"&#39;","")
  641.        fString = replace(fString, ">", "")
  642.        fString = replace(fString, "<", "")
  643.        fString = Replace(fString, CHR(9), " ")'&nbsp;
  644.        fString = Replace(fString, CHR(10), "")
  645.        fString = Replace(fString, CHR(13), "")
  646.        fString = Replace(fString, CHR(34), "")
  647.        fString = Replace(fString, CHR(32), " ")'space
  648.        fString = Replace(fString, CHR(39), "")
  649.        fString = Replace(fString, CHR(10) & CHR(10),"")
  650.        fString = Replace(fString, CHR(10)&CHR(13), "")
  651.        fString=Trim(fString)
  652.        FpHtmlEnCode=fString
  653.    Else
  654.        FpHtmlEnCode="$False$"
  655.    End If
  656. End Function
  657.  
  658. '==================================================
  659. '函数名:GetPaing
  660. '作  用:获取分页
  661. '==================================================
  662. Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
  663. If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
  664.    GetPaing="$False$"
  665.    Exit Function
  666. End If
  667.  
  668. Dim Start,Over,ConTemp,TempStr
  669. TempStr=LCase(ConStr)
  670. StartStr=LCase(StartStr)
  671. OverStr=LCase(OverStr)
  672. Over=Instr(1,TempStr,OverStr)
  673. If Over<=0 Then
  674.    GetPaing="$False$"
  675.    Exit Function
  676. Else
  677.    If IncluR=True Then
  678.       Over=Over+Len(OverStr)
  679.    End If
  680. End If
  681. TempStr=Mid(TempStr,1,Over)
  682. Start=InstrRev(TempStr,StartStr)
  683. If IncluL=False Then
  684.    Start=Start+Len(StartStr)
  685. End If
  686.  
  687. If Start<=0 Or Start>=Over Then
  688.    GetPaing="$False$"
  689.    Exit Function
  690. End If
  691. ConTemp=Mid(ConStr,Start,Over-Start)
  692.  
  693. ConTemp=Trim(ConTemp)
  694. ConTemp=Replace(ConTemp," ","")
  695. ConTemp=Replace(ConTemp,",","")
  696. ConTemp=Replace(ConTemp,"'","")
  697. ConTemp=Replace(ConTemp,"""","")
  698. ConTemp=Replace(ConTemp,">","")
  699. ConTemp=Replace(ConTemp,"<","")
  700. ConTemp=Replace(ConTemp,"&nbsp;","")
  701. GetPaing=ConTemp
  702. End Function
  703.  
  704. '==================================================
  705. '函数名:ScriptHtml
  706. '作  用:过滤html标记
  707. '参  数:ConStr ------ 要过滤的字符串
  708. '==================================================
  709. Function ScriptHtml(Byval ConStr,TagName,FType)
  710.     Dim Re
  711.     Set Re=new RegExp
  712.     Re.IgnoreCase =true
  713.     Re.Global=True
  714.     Select Case FType
  715.     Case 1
  716.        Re.Pattern="<" & TagName & "([^>])*>"
  717.        ConStr=Re.Replace(ConStr,"")
  718.     Case 2
  719.        Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
  720.        ConStr=Re.Replace(ConStr,"")
  721.     Case 3
  722.        Re.Pattern="<" & TagName & "([^>])*>"
  723.        ConStr=Re.Replace(ConStr,"")
  724.        Re.Pattern="</" & TagName & "([^>])*>"
  725.        ConStr=Re.Replace(ConStr,"")
  726.     End Select
  727.     ScriptHtml=ConStr
  728.     Set Re=Nothing
  729. End Function
  730.  
  731. Function CheckDir(byval FolderPath)
  732.         dim fso
  733.         Set fso = Server.CreateObject("Scripting.FileSystemObject")
  734.         If fso.FolderExists(Server.MapPath(folderpath)) then
  735.         '存在
  736.                 CheckDir = True
  737.         Else
  738.         '不存在
  739.                 CheckDir = False
  740.         End if
  741.         Set fso = nothing
  742. End Function
  743. Function MakenewsDir(byval foldername)
  744.         dim fso
  745.         Set fso = Server.CreateObject("Scripting.FileSystemObject")
  746.         fso.CreateFolder(Server.MapPath(foldername))
  747.         If fso.FolderExists(Server.MapPath(foldername)) Then
  748.            MakenewsDir = True
  749.         Else
  750.            MakenewsDir = False
  751.         End If
  752.         Set fso = nothing
  753. End Function
  754.  
  755. '**************************************************
  756. '函数名:IsObjInstalled
  757. '作  用:检查组件是否已经安装
  758. '参  数:strClassString ----组件名
  759. '返回值:True  ----已经安装
  760. '       False ----没有安装
  761. '**************************************************
  762. Function IsObjInstalled(strClassString)
  763.         IsObjInstalled = False
  764.         Err = 0
  765.         Dim xTestObj
  766.         Set xTestObj = Server.CreateObject(strClassString)
  767.         If 0 = Err Then IsObjInstalled = True
  768.         Set xTestObj = Nothing
  769.         Err = 0
  770. End Function
  771.  
  772. '**************************************************
  773. '过程名:WriteErrMsg
  774. '作  用:显示错误提示信息
  775. '参  数:无
  776. '**************************************************
  777. sub WriteErrMsg(ErrMsg)
  778.         dim strErr
  779.         strErr=strErr & "<table width=""60%"" align=""center"" border=""0"" cellpadding=""2"" cellspacing=""1"" class=""mtab"" bgcolor=""#8ED1FF"">" & vbcrlf
  780.         strErr=strErr & "<tr><td class=""td28"">错误信息!</td></tr>" & vbcrlf
  781.         strErr=strErr & "<tr><td align=""center"" bgcolor=""#FFFFFF""><br><b>产生错误的可能原因:</b>" & ErrMsg &"<br><br></td></tr>" & vbcrlf
  782.         strErr=strErr & "<tr align='center' bgcolor=""#FFFFFF""><td><a href='javascript:history.go(-1)'>&lt;&lt; 返回上一页</a></td></tr>" & vbcrlf
  783.         strErr=strErr & "</table>" & vbcrlf
  784.         response.write strErr
  785. end sub
  786.  
  787. '**************************************************
  788. '过程名:WriteSucced
  789. '作  用:显示成功提示信息
  790. '参  数:无
  791. '**************************************************
  792. sub WriteSucced(ErrMsg)
  793.         dim strErr
  794.         strErr=strErr & "<table width=""60%"" align=""center"" border=""0"" cellpadding=""2"" cellspacing=""1"" class=""mtab"" bgcolor=""#8ED1FF"">" & vbcrlf
  795.         strErr=strErr & "<tr><td class=""td28"">恭喜你!</td></tr>" & vbcrlf
  796.         strErr=strErr & "<tr><td align=""center"" bgcolor=""#FFFFFF""><br /><br />"&ErrMsg&"<br /><br /><br /></td></tr>" & vbcrlf
  797.         strErr=strErr & "<tr align='center' bgcolor=""#FFFFFF""><td><a href='Admin_ItemStart.asp'>开始采集</a>&nbsp;&nbsp;&nbsp;&nbsp;<a href='Admin_ItemManage.asp'>项目管理</a></td></tr>" & vbcrlf
  798.         strErr=strErr & "</table>" & vbcrlf
  799.         response.write strErr
  800. end sub
  801.  
  802. '**************************************************
  803. '函数名:ShowPage
  804. '作  用:显示“上一页 下一页”等信息
  805. '参  数:sFileName  ----链接地址
  806. '       TotalNumber ----总数量
  807. '       MaxPerPage  ----每页数量
  808. '       ShowTotal   ----是否显示总数量
  809. '       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用,否则会出现JS错误。
  810. '       strUnit     ----计数单位
  811. '返回值:“上一页 下一页”等信息的HTML代码
  812. '**************************************************
  813. function ShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)
  814.         dim TotalPage,strTemp,strUrl,i
  815.  
  816.         if TotalNumber=0 or MaxPerPage=0 or isNull(MaxPerPage) then
  817.                 ShowPage=""
  818.                 exit function
  819.         end if
  820.         if totalnumber mod maxperpage=0 then
  821.         TotalPage= totalnumber \ maxperpage
  822.         else
  823.         TotalPage= totalnumber \ maxperpage+1
  824.         end if
  825.         if CurrentPage>TotalPage then CurrentPage=TotalPage
  826.                
  827.         strTemp= "<table align='center'><tr><td>"
  828.         if ShowTotal=true then
  829.                 strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "&nbsp;&nbsp;"
  830.         end if
  831.         strUrl=JoinChar(sfilename)
  832.         if CurrentPage<2 then
  833.         strTemp=strTemp & "首页 上一页&nbsp;"
  834.         else
  835.         strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
  836.         strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a>&nbsp;"
  837.         end if
  838.  
  839.         if CurrentPage>=TotalPage then
  840.         strTemp=strTemp & "下一页 尾页"
  841.         else
  842.         strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a>&nbsp;"
  843.         strTemp=strTemp & "<a href='" & strUrl & "page=" & TotalPage & "'>尾页</a>"
  844.         end if
  845.         strTemp=strTemp & "&nbsp;页次:<strong><font color=red>" & CurrentPage & "</font>/" & TotalPage & "</strong>页 "
  846.         strTemp=strTemp & "&nbsp;<b>" & maxperpage & "</b>" & strUnit & "/页"
  847.         if ShowAllPages=True then
  848.                 strTemp=strTemp & "&nbsp;&nbsp;转到第<input type='text' name='page' size='3' maxlength='5' value='" & CurrentPage & "' onKeyPress=""if (event.keyCode==13) window.location='" & strUrl & "page=" & "'+this.value;""'>页"
  849.         end if
  850.         strTemp=strTemp & "</td></tr></table>"
  851. response.Write(strTemp)
  852. 'ShowPage=strTemp
  853. end function
  854.  
  855. '**************************************************
  856. '函数名:JoinChar
  857. '作  用:向地址中加入 ? 或 &
  858. '参  数:strUrl  ----网址
  859. '返回值:加了 ? 或 & 的网址
  860. '**************************************************
  861. function JoinChar(strUrl)
  862.         if strUrl="" then
  863.                 JoinChar=""
  864.                 exit function
  865.         end if
  866.         if InStr(strUrl,"?")<len(strUrl) then
  867.                 if InStr(strUrl,"?")>1 then
  868.                         if InStr(strUrl,"&")<len(strUrl) then
  869.                                 JoinChar=strUrl & "&"
  870.                         else
  871.                                 JoinChar=strUrl
  872.                         end if
  873.                 else
  874.                         JoinChar=strUrl & "?"
  875.                 end if
  876.         else
  877.                 JoinChar=strUrl
  878.         end if
  879. end function
  880.  
  881. '**************************************************
  882. '函数名:CreateKeyWord
  883. '作  用:由给定的字符串生成关键字
  884. '参  数:Constr---要生成关键字的原字符串
  885. '返回值:生成的关键字
  886. '**************************************************
  887. Function CreateKeyWord(byval Constr,Num)
  888.    If Constr="" or IsNull(Constr)=True or Constr="$False$" Then
  889.       CreateKeyWord="$False$"
  890.       Exit Function
  891.    End If
  892.    If Num="" or IsNumeric(Num)=False Then
  893.       Num=2
  894.    End If
  895.    Constr=Replace(Constr,CHR(32),"")
  896.    Constr=Replace(Constr,CHR(9),"")
  897.    Constr=Replace(Constr,"&nbsp;","")
  898.    Constr=Replace(Constr," ","")
  899.    Constr=Replace(Constr,"(","")
  900.    Constr=Replace(Constr,")","")
  901.    Constr=Replace(Constr,"<","")
  902.    Constr=Replace(Constr,">","")
  903.    Constr=Replace(Constr,"""","")
  904.    Constr=Replace(Constr,"?","")
  905.    Constr=Replace(Constr,"*","")
  906.    Constr=Replace(Constr,"|","")
  907.    Constr=Replace(Constr,",","")
  908.    Constr=Replace(Constr,".","")
  909.    Constr=Replace(Constr,"/","")
  910.    Constr=Replace(Constr,"\","")
  911.    Constr=Replace(Constr,"-","")
  912.    Constr=Replace(Constr,"@","")
  913.    Constr=Replace(Constr,"#","")
  914.    Constr=Replace(Constr,"$","")
  915.    Constr=Replace(Constr,"%","")
  916.    Constr=Replace(Constr,"&","")
  917.    Constr=Replace(Constr,"+","")
  918.    Constr=Replace(Constr,":","")
  919.    Constr=Replace(Constr,":","")  
  920.    Constr=Replace(Constr,"‘","")
  921.    Constr=Replace(Constr,"“","")
  922.    Constr=Replace(Constr,"”","")        
  923.    Dim i,ConstrTemp
  924.    For i=1 To Len(Constr)
  925.       ConstrTemp=ConstrTemp & "|" & Mid(Constr,i,Num)
  926.    Next
  927.    If Len(ConstrTemp)<254 Then
  928.       ConstrTemp=ConstrTemp & "|"
  929.    Else
  930.       ConstrTemp=Left(ConstrTemp,254) & "|"
  931.    End If
  932.    CreateKeyWord=ConstrTemp
  933. End Function
  934.  
  935. Function CheckUrl(strUrl)
  936.    Dim Re
  937.    Set Re=new RegExp
  938.    Re.IgnoreCase =true
  939.    Re.Global=True
  940.    Re.Pattern="http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
  941.    If Re.test(strUrl)=True Then
  942.       CheckUrl=strUrl
  943.    Else
  944.       CheckUrl="$False$"
  945.    End If
  946.    Set Rs=Nothing
  947. End Function
  948. %>
  949.  
  950.  
downloadFunction.asp Source code - Download Jie Yang v0.6.3 article system Source code
Related Source Codes/Software:
Jilin classification information release system v5.0 trial version - A ready-made classifieds site publishing system, h... 2016-09-21
Linyi CMS v6.5 market classification information - A. supply and demand information function: informa... 2016-09-21
Tesco discount net SQL version - And presentations, faster. 2016-09-21
- electronic enterprise website management system In a fully functional version - Super suitable for enterprise agents build a corpo... 2016-09-21
Rio mesh network hard disk system v3.0 - System functions: 1, increase the progress of Asp... 2016-09-21
Classified information network business in suzhou - Overall module: classification of supply and deman... 2016-09-21
NPOINT virtual host v1.7.0 formal version management system - The system main function is introduced 2016-09-21
IDC sales web site - Beautiful IDC sales web site source code 2016-09-21
Oo 126 CMS movie site system - This procedure ASP + ACC/ASP + SQL, using new kern... 2016-09-21
Pcook CMS bubble guest v3.0 SDCMS version - Developed by Asp+Access, and meet the needs of sma... 2016-09-21
CRYENGINE - CRYENGINE is a powerful real-time game development... 2017-06-11
postal - 2017-06-11
reactide - Reactide is the first dedicated IDE for React web ... 2017-06-11
rkt - rkt is a pod-native container engine for Linux. It... 2017-06-11
uWebSockets - Tiny WebSockets https://for... 2017-06-11
realworld - TodoMVC for the RealWorld - Exemplary fullstack Me... 2017-06-11
goreplay - GoReplay is an open-source tool for capturing and ... 2017-06-10
pyenv - Simple Python version management 2017-06-10
redux-saga - An alternative side effect model for Redux apps ... 2017-06-10
angular-starter - 2017-06-10

 Back to top