admin_classcollection.asp

依蓝旅游网站管理系统Elan2008.SP2

       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,"")
		  Case 4:
		     Re.Pattern = "<[\w]{1,} (.+?)" & TagName & "\s*=[^<>]*\>"
             Set Matches = Re.Execute(ConStr)
			 For Each Match In Matches 
			    Re.Pattern = "[ ]"& TagName &"[ ]*="
			    ConStr = Replace(ConStr, Match.Value, Re.Replace(Match.Value, " "))
			 Next
          Case 5:
		     Re.Pattern = "\<[\w]{1,} (.+?)(onMouseWheel|onClick|onDblClick|onMouseDown|onMouseUp|onMouseOver|onMouseMove|onMouseOut|onKeyPress|onKeyDown|onKeyUp|onAbort|onBeforeUnload|onError|onLoad|onMove|onResize|onScroll|onStop|onUnload|onBlur|onChange|onFocus|onReset|onSubmit|onBounce|onFinish|onStart|onBeforeCopy|onBeforeCut|onBeforeEditFocus|onBeforePaste|onBeforeUpdate|onContextMenu|onCopy|onCut|onDrag|onDragDrop|onDragEnd|onDragEnter|onDragLeave|onDragOver|onDragStart|onDrop|onLoseCapture|onPaste|onSelect|onSelectStart|onAfterUpdate|onCellChange|onDataAvailable|onDatasetChanged|onDatasetComplete|onErrorUpdate|onRowEnter|onRowExit|onRowsDelete|onRowsInserted|onAfterPrint|onBeforePrint|onFilterChange|onHelp|onPropertyChange|onReadyStateChange)[ ]*=(.+?)>"
			 Set Matches = Re.Execute(ConStr)
			 For Each Match In Matches 
			    Re.Pattern = "[ ](onMouseWheel|onClick|onDblClick|onMouseDown|onMouseUp|onMouseOver|onMouseMove|onMouseOut|onKeyPress|onKeyDown|onKeyUp|onAbort|onBeforeUnload|onError|onLoad|onMove|onResize|onScroll|onStop|onUnload|onBlur|onChange|onFocus|onReset|onSubmit|onBounce|onFinish|onStart|onBeforeCopy|onBeforeCut|onBeforeEditFocus|onBeforePaste|onBeforeUpdate|onContextMenu|onCopy|onCut|onDrag|onDragDrop|onDragEnd|onDragEnter|onDragLeave|onDragOver|onDragStart|onDrop|onLoseCapture|onPaste|onSelect|onSelectStart|onAfterUpdate|onCellChange|onDataAvailable|onDatasetChanged|onDatasetComplete|onErrorUpdate|onRowEnter|onRowExit|onRowsDelete|onRowsInserted|onAfterPrint|onBeforePrint|onFilterChange|onHelp|onPropertyChange|onReadyStateChange)[ ]*="
			    ConStr = Replace(ConStr, Match.Value, Re.Replace(Match.Value, " "))
			 Next
	   End Select
       FliterScript = ConStr
       Set Re = Nothing
   End Function
   
   Public Function ReplaceSaveRemoteFile(ByVal ConStr, ByVal strInstallDir, ByVal strChannelDir, ByVal strUploadDir, ByVal SaveTf, ByVal TistUrl, PictrueNum, ByVal Watermark, ByVal FirstThumb, Uploadfiles)
      If ConStr="$RequestError" Or ConStr = "" 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
         TempStr = EL_Common.Join2String(TempStr, Match.Value, "$Array$")
      Next
      If TempStr<>"" Then
         TempArray=Split(TempStr,"$Array$")
         TempStr=""
         For Tempi=0 To Ubound(TempArray)
            Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
            Set Matches =Re.Execute(TempArray(Tempi)) 
            For Each Match in Matches
			   TempStr = EL_Common.Join2String(TempStr, Match.Value, "$Array$")
            Next
         Next
      End if
      If TempStr<>"" Then
         Re.Pattern ="src\s*=\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, SubDir
      DtNow=Now()
      If SaveTf=True then
	     SubDir = year(DtNow) & right("0" & month(DtNow),2) &"/"
         SavePath= strInstallDir & strChannelDir &"/"& strUploadDir &"/"& SubDir
         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 = EL_Common.Join2String(TempStr, TempArray(Tempi), "$Array$")
         End If
      Next      
      TempArray=Split(TempStr,"$Array$")
      '去掉重复图片结束
   
      '转换相对图片地址开始
      TempStr=""
      For Tempi=0 To Ubound(TempArray)
		 TempStr = EL_Common.Join2String(TempStr, ConvertURL(TempArray(Tempi), TistUrl), "$Array$")
      Next
      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<>"$RequestError" And SaveTf=True Then'保存图片
            ArrSaveFileName = Split(RemoteFileurl,".")
   	        strFileType=LCase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
            If strFileType<>"gif" And strFileType<>"jpg" And strFileType<>"bmp" And strFileType<>"jpeg" And strFileType<>"png" then
               UploadFiles=""
               ReplaceSaveRemoteFile=ConStr
               Exit Function
            End If
   
            Randomize
            RanNum=int(9999*rnd)+1000
   	        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)
			Dim ThumbFile
			ThumbFile = ""
			If Tempi > 0 Then FirstThumb = False
   	        If SaveRemoteFile(SavePath, strFileName, RemoteFileUrl, Watermark, FirstThumb, ThumbFile, SubDir) = True Then
               PathTemp = SavePath & strFileName
               ConStr = Re.Replace(ConStr, PathTemp)
               Re.Pattern=strInstallDir & strChannelDir & "/"
			   If ThumbFile <> "" Then UploadFiles = EL_Common.Join2String(UploadFiles, ThumbFile, "|")
			   UploadFiles = EL_Common.Join2String(UploadFiles, SubDir & strFileName, "|")
            Else
               PathTemp=RemoteFileUrl
               ConStr=Re.Replace(ConStr, PathTemp)
            End If
         ElseIf RemoteFileurl<>"$RequestError" And SaveTf=False Then'不保存图片
            Re.Pattern =TempArray(Tempi)
            ConStr = Re.Replace(ConStr,RemoteFileUrl)
			UploadFiles = EL_Common.Join2String(UploadFiles, RemoteFileUrl, "|")
         End If
      Next   
      Set Re=nothing
	  PictrueNum = UBound(Split(UploadFiles, "|"))+1
      ReplaceSaveRemoteFile = ConStr
   End function
   
   Private Function SaveRemoteFile(ByVal SavePath, ByVal FileName, ByVal RemoteFileUrl, ByVal Watermark, ByVal CreateThumb, ThumbFile, ByVal SubDir)
      SaveRemoteFile = True
	  Dim Ads,Retrieval,GetRemoteData, LocalFileName
	  LocalFileName = SavePath & FileName
	  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
	  ThumbFile = CreateWatermark(LocalFileName, Watermark, CreateThumb, SubDir)
	  Set Ads=nothing
   End Function
   
   Private Function CreateWatermark(ByVal FilePath, ByVal Watermark, ByVal CreateThumb, ByVal StrFolder)      
	  CreateWatermark = ""
	  Dim JpegWatermark
	  Set JpegWatermark = New ClassJpeg
	  If JpegWatermark.ErrorCode = 0 Then
	     If Watermark Then JpegWatermark.CreateWatermark Server.MapPath(FilePath)
	     If CreateThumb = True Then
	        JpegWatermark.CreateThumb Server.MapPath(FilePath), 1 
	        CreateWatermark = StrFolder & JpegWatermark.ThumbFileName
	     End If
	  End If
	  Set JpegWatermark = Nothing
   End Function
   
   Private Function CheckDir(ByVal FolderPath)
      Dim fso
	  Set fso = Server.CreateObject(Object_FSO)
	  If fso.FolderExists(Server.MapPath(folderpath)) then
	     CheckDir = True
	  Else
	     CheckDir = False
	  End if
	  Set fso = nothing
   End Function
   
   Private Function MakeNewsDir(byval foldername)
      dim fso
      Set fso = Server.CreateObject(Object_FSO)
      fso.CreateFolder(Server.MapPath(foldername))
      If fso.FolderExists(Server.MapPath(foldername)) Then
         MakeNewsDir = True
      Else
         MakeNewsDir = False
      End If
      Set fso = nothing
   End Function
End Class
%>