一些有用的asp函数

' ==================================================
' 函数名：ReplaceSaveRemoteFile
' 作  用：替换、保存远程图片
' 参  数：ConStr ------ 要替换的字符串
' 参  数：SaveTf ------ 是否保存文件，False不保存，True保存
' 参  数: TistUrl------ 当前网页地址
' ==================================================
Function  ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
    If  ConStr = " $False$ "   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  = " srcs*=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  = " srcs*=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  &   " / "
      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 )
   TempArray = Split (TempStr, " $Array$ " )
    ' 去掉重复图片结束

    ' 转换相对图片地址开始
   TempStr = ""
    For  Tempi = 0   To   Ubound (TempArray)
      TempStr = TempStr  &   " $Array$ "   &  DefiniteUrl(TempArray(Tempi),TistUrl)
    Next
   TempStr = Right (TempStr, Len (TempStr) - 7 )
   TempStr = Replace (TempStr, Chr ( 0 ), "" )
   TempArray2 = Split (TempStr, " $Array$ " )
   TempStr = ""
    ' 转换相对图片地址结束

    ' 图片替换/保存
    Set  Re  =   New  Regexp
   Re.IgnoreCase  =   True  
   Re.Global  =   True

    For  Tempi = 0   To   Ubound (TempArray2)
      RemoteFileUrl = TempArray2(Tempi)
       If  RemoteFileUrl <> " $False$ "   And  SaveTf = True   Then ' 保存图片
         ArrSaveFileName  =   Split (RemoteFileurl, " . " )
     strFileType = Lcase (ArrSaveFileName( Ubound (ArrSaveFileName))) ' 文件类型
          If  strFileType = " asp "   or  strFileType = " asa "   or  strFileType = " aspx "   or  strFileType = " cer "   or  strFileType = " cdx "   or  strFileType = " exe "   or  strFileType = " rar "   or  strFileType = " zip "   then
            UploadFiles = ""
            ReplaceSaveRemoteFile = ConStr
             Exit   Function
          End   If

          Randomize
         RanNum = Int ( 900 * Rnd ) + 100
     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
         Re.Pattern  = TempArray(Tempi)
      If  SaveRemoteFile(SavePath  &  strFileName,RemoteFileUrl) = True   Then
' ********************************
            PathTemp = SavePath  &  strFileName
            ConStr = Re.Replace(ConStr,PathTemp)
            Re.Pattern = strInstallDir  &  strChannelDir  &   " / "
            UploadFiles = UploadFiles  &   " | "   &  Re.Replace(SavePath  & strFileName, "" )
          Else
            PathTemp = RemoteFileUrl
            ConStr = Re.Replace(ConStr,PathTemp)
             ' UploadFiles=UploadFiles & "|" & RemoteFileUrl
          End   If
       ElseIf  RemoteFileurl <> " $False$ "   and  SaveTf = False   Then ' 不保存图片
         Re.Pattern  = TempArray(Tempi)
         ConStr = Re.Replace(ConStr,RemoteFileUrl)
         UploadFiles = UploadFiles  &   " | "   &  RemoteFileUrl
       End   If
    Next    
    Set  Re = nothing
    If  UploadFiles <> ""   Then
      UploadFiles = Right (UploadFiles, Len (UploadFiles) - 1 )
    End   If
   ReplaceSaveRemoteFile = ConStr
End function

 

' ==================================================
' 过程名：SaveRemoteFile
' 作  用：保存远程的文件到本地
' 参  数：LocalFileName ------ 本地文件名
' 参  数：RemoteFileUrl ------ 远程文件URL
' ==================================================
Function  SaveRemoteFile(LocalFileName,RemoteFileUrl)
    SaveRemoteFile = True
     dim  Ads,Retrieval,GetRemoteData
     Set  Retrieval  =  Server.CreateObject( " Microsoft.XMLHTTP " )
     With  Retrieval
        .Open  " Get " , RemoteFileUrl,  False ,  "" ,  ""
        .Send
         If  .Readystate <> 4   then
            SaveRemoteFile = False
             Exit   Function
         End   If
        GetRemoteData  =  .ResponseBody
     End   With
     Set  Retrieval  =   Nothing
     Set  Ads  =  Server.CreateObject( " Adodb.Stream " )
     With  Ads
        .Type  =   1
        .Open
        .Write GetRemoteData
        .SaveToFile server.MapPath(LocalFileName), 2
        .Cancel()
        .Close()
     End   With
     Set  Ads = nothing
end Function

' ==================================================
' 函数名：FpHtmlEnCode
' 作  用：标题过滤
' 参  数：fString ------字符串
' ==================================================
Function  FpHtmlEnCode(fString)
    If   IsNull (fString) = False   or  fString <> ""   or  fString <> " $False$ "   Then
       fString = nohtml(fString)
       fString = FilterJS(fString)
       fString  =   Replace (fString, " &nbsp; " , "   " )
       fString  =   Replace (fString, " &quot; " , "" )
       fString  =   Replace (fString, " &#39; " , "" )
       fString  =   replace (fString,  " > " ,  "" )
       fString  =   replace (fString,  " < " ,  "" )
       fString  =   Replace (fString,  CHR ( 9 ),  "   " ) ' &nbsp;
       fString  =   Replace (fString,  CHR ( 10 ),  "" )
       fString  =   Replace (fString,  CHR ( 13 ),  "" )
       fString  =   Replace (fString,  CHR ( 34 ),  "" )
       fString  =   Replace (fString,  CHR ( 32 ),  "   " ) ' space
       fString  =   Replace (fString,  CHR ( 39 ),  "" )
       fString  =   Replace (fString,  CHR ( 10 )  &   CHR ( 10 ), "" )
       fString  =   Replace (fString,  CHR ( 10 ) & CHR ( 13 ),  "" )
       fString = Trim (fString)
       FpHtmlEnCode = fString
    Else
       FpHtmlEnCode = " $False$ "
    End   If
End Function

' ==================================================
' 函数名：GetPaing
' 作  用：获取分页
' ==================================================
Function  GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
If  ConStr = " $False$ "   or  ConStr = ""   Or  StartStr = ""   Or  OverStr = ""   or   IsNull (ConStr) = True   or   IsNull (StartStr) = True   Or   IsNull (OverStr) = True   Then
   GetPaing = " $False$ "
    Exit   Function
End   If

Dim  Start,Over,ConTemp,TempStr
TempStr = LCase (ConStr)
StartStr = LCase (StartStr)
OverStr = LCase (OverStr)
Over = Instr ( 1 ,TempStr,OverStr)
If  Over <= 0   Then
   GetPaing = " $False$ "
    Exit   Function
Else
    If  IncluR = True   Then
      Over = Over + Len (OverStr)
    End   If
End   If
TempStr = Mid (TempStr, 1 ,Over)
Start = InstrRev (TempStr,StartStr)
If  IncluL = False   Then
   Start = Start + Len (StartStr)
End   If

If  Start <= 0   Or  Start >= Over  Then
   GetPaing = " $False$ "
    Exit   Function
End   If
ConTemp = Mid (ConStr,Start,Over - Start)

ConTemp = Trim (ConTemp)
ConTemp = Replace (ConTemp, "   " , "" )
ConTemp = Replace (ConTemp, " , " , "" )
ConTemp = Replace (ConTemp, " ' " , "" )
ConTemp = Replace (ConTemp, " "" " , "" )
ConTemp = Replace (ConTemp, " > " , "" )
ConTemp = Replace (ConTemp, " < " , "" )
ConTemp = Replace (ConTemp, " &nbsp; " , "" )
GetPaing = ConTemp
End Function

' ==================================================
' 函数名：ScriptHtml
' 作  用：过滤html标记
' 参  数：ConStr ------ 要过滤的字符串
' ==================================================
Function  ScriptHtml(Byval ConStr,TagName,FType)
     Dim  Re
     Set  Re = new  RegExp
    Re.IgnoreCase  = true
    Re.Global = True
     Select   Case  FType
     Case   1
       Re.Pattern = " < "   &  TagName  &   " ([^>])*> "
       ConStr = Re.Replace(ConStr, "" )
     Case   2
       Re.Pattern = " < "   &  TagName  &   " ([^>])*>.*?</ "   &  TagName  &   " ([^>])*> "
       ConStr = Re.Replace(ConStr, "" )
     Case   3
       Re.Pattern = " < "   &  TagName  &   " ([^>])*> "
       ConStr = Re.Replace(ConStr, "" )
       Re.Pattern = " </ "   &  TagName  &   " ([^>])*> "
       ConStr = Re.Replace(ConStr, "" )
     End   Select
    ScriptHtml = ConStr
     Set  Re = Nothing
End Function

Function  CheckDir(byval FolderPath)
     dim  fso
     Set  fso  =  Server.CreateObject( " Scripting.FileSystemObject " )
     If  fso.FolderExists(Server.MapPath(folderpath))  then
     ' 存在
        CheckDir  =   True
     Else
     ' 不存在
        CheckDir  =   False
     End   if
     Set  fso  =   nothing
End Function
Function  MakeNewsDir(byval foldername)
     dim  fso
     Set  fso  =  Server.CreateObject( " Scripting.FileSystemObject " )
        fso.CreateFolder(Server.MapPath(foldername))
         If  fso.FolderExists(Server.MapPath(foldername))  Then
           MakeNewsDir  =   True
         Else
           MakeNewsDir  =   False
         End   If
     Set  fso  =   nothing
End Function

' **************************************************
' 函数名：IsObjInstalled
' 作  用：检查组件是否已经安装
' 参  数：strClassString ----组件名
' 返回值：True  ----已经安装
'        False ----没有安装
' **************************************************
Function  IsObjInstalled(strClassString)
    IsObjInstalled  =   False
    Err  =   0
     Dim  xTestObj
     Set  xTestObj  =  Server.CreateObject(strClassString)
     If   0   =  Err  Then  IsObjInstalled  =   True
     Set  xTestObj  =   Nothing
    Err  =   0
End Function

' ==================================================
' 函数名：GetHttpPage
' 作  用：获取网页源码
' 参  数：HttpUrl ------网页地址
' ==================================================
Function  GetHttpPage(HttpUrl)
    If   IsNull (HttpUrl) = True   Or   Len (HttpUrl) < 18   Or  HttpUrl = " $False$ "   Then
      GetHttpPage = " $False$ "
       Exit   Function
    End   If
    Dim  Http
    Set  Http = server.createobject( " MSXML2.XMLHTTP " )
   Http.open  " GET " ,HttpUrl, False
   Http.Send()
    If  Http.Readystate <> 4   then
       Set  Http = Nothing  
      GetHttpPage = " $False$ "
       Exit   function
    End   if
   GetHTTPPage = bytesToBSTR(Http.responseBody, " GB2312 " )
    Set  Http = Nothing
    If  Err.number <> 0   then
      Err.Clear
    End   If
End Function

' ==================================================
' 函数名：BytesToBstr
' 作  用：将获取的源码转换为中文
' 参  数：Body ------要转换的变量
' 参  数：Cset ------要转换的类型
' ==================================================
Function  BytesToBstr(Body,Cset)
    Dim  Objstream
    Set  Objstream  =  Server.CreateObject( " adodb.stream " )
   objstream.Type  =   1
   objstream.Mode  = 3
   objstream.Open
   objstream.Write body
   objstream.Position  =   0
   objstream.Type  =   2
   objstream.Charset  =  Cset
   BytesToBstr  =  objstream.ReadText 
   objstream.Close
    set  objstream  =   nothing
End Function

' ==================================================
' 函数名：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  =   " $False$ "
         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 = " $False$ "   or  ConStr = ""   or   IsNull (ConStr) = True   Or  StartStr = ""   or   IsNull (StartStr) = True   Or  OverStr = ""   or   IsNull (OverStr) = True   Then
      GetBody = " $False$ "
       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 = " $False$ "
       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 = " $False$ "
       Exit   Function
    Else
       If  IncluR = True   Then
         Over = Over + LenB(OverStr)
       End   If
    End   If
   GetBody = MidB(ConStr,Start,Over - Start)
End Function