powereasy.xmlhttp.asp

个人网站比较简短

<%
'**************************************************************
' Software name: PowerEasy SiteWeaver
' Web: http://www.powereasy.net
' Copyright (C) 2005－2008 佛山市动易网络科技有限公司 版权所有
'**************************************************************

'==================================================
'函数名：GetHttpPage
'作  用：获取网页源码
'参  数：HttpUrl ------要获取源码的网页地址
'      ：Coding  ------编码， 1 GB 2 UTF
'==================================================
Function GetHttpPage(HttpUrl, Coding)
    On Error Resume Next
    If IsNull(HttpUrl) = True Or Len(HttpUrl) < 18 Or HttpUrl = "" Then
        GetHttpPage = ""
        Exit Function
    End If
    Dim Http
    Set Http = Server.CreateObject("MSXML2.XMLHTTP")
    Http.Open "GET", HttpUrl, False
    Http.Send
    If Http.Readystate <> 4 Then
        GetHttpPage = ""
        Exit Function
    End If
    If Coding = 1 Then
        GetHttpPage = BytesToBstr(Http.ResponseBody, "UTF-8")
    ElseIf Coding = 2 Then
        GetHttpPage = BytesToBstr(Http.ResponseBody, "Big5")
    Else
        GetHttpPage = BytesToBstr(Http.ResponseBody, "GB2312")
    End If
    
    Set Http = Nothing
    If Err.Number <> 0 Then
        Err.Clear
    End If
End Function

'==================================================
'函数名：PostHttpPage
'作  用：登录
'==================================================
Function PostHttpPage(RefererUrl, PostUrl, PostData, Coding)
    On Error Resume Next
    Dim xmlHttp
    Dim RetStr
    Set xmlHttp = Server.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 Then
        Set xmlHttp = Nothing
        PostHttpPage = "$False$"
        Exit Function
    End If
    If Coding = 1 Then
        PostHttpPage = BytesToBstr(xmlHttp.ResponseBody, "UTF-8")
    ElseIf Coding = 2 Then
        PostHttpPage = BytesToBstr(xmlHttp.ResponseBody, "Big5")
    Else
        PostHttpPage = BytesToBstr(xmlHttp.ResponseBody, "GB2312")
    End If
    
    Set xmlHttp = Nothing
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

'==================================================
'函数名：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 Start, Over

    Start = InStrB(1, ConStr, StartStr, vbBinaryCompare)

    If Start <= 0 Then
        Start = InStrB(1, ConStr, Replace(StartStr, vbCrLf, Chr(10)), vbBinaryCompare)
        If Start <= 0 Then
            Start = InStrB(1, ConStr, Replace(StartStr, vbCrLf, Chr(13)), vbBinaryCompare)
            If Start <= 0 Then
                GetBody = "$False$"
                Exit Function
            Else
                If IncluL = False Then
                    Start = Start + LenB(StartStr)
                End If
            End If
        Else
            If IncluL = False Then
                Start = Start + LenB(StartStr)
            End If
        End If
    Else
        If IncluL = False Then
            Start = Start + LenB(StartStr)
        End If
    End If

    Over = InStrB(Start, ConStr, OverStr, vbBinaryCompare)
    If Over <= 0 Or Over <= Start Then
        Over = InStrB(Start, ConStr, Replace(OverStr, vbCrLf, Chr(10)), vbBinaryCompare)
        If Over <= 0 Or Over <= Start Then
            Over = InStrB(Start, ConStr, Replace(OverStr, vbCrLf, Chr(13)), 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
        Else
            If IncluR = True Then
                Over = Over + LenB(OverStr)
            End If
        End If
    Else
        If IncluR = True Then
            Over = Over + LenB(OverStr)
        End If
    End If

    GetBody = MidB(ConStr, Start, Over - Start)
End Function


'==================================================
'函数名：ReplaceRemoteUrl
'作  用：替换字符串中的远程文件为本地文件并保存远程文件
'参  数：strContent ------ 要替换的字符串
'==================================================
Function ReplaceRemoteUrl(ByVal strContent)
    If IsObjInstalled("Microsoft.XMLHTTP") = False Or ObjInstalled_FSO = False Then
        ReplaceRemoteUrl = strContent
        Exit Function
    End If
    Dim RemoteFiles, RemoteFile, RemoteFileUrl, SaveFilePath, SavePath, SavePath2, SaveFileName, ThumbFileName, SaveFileType, arrSaveFileName, ranNum, dtNow, FileCount, SavedFiles
    Dim temptime, FilesArray, tempi
    If fso.FolderExists(Server.MapPath(InstallDir)) = False Then fso.CreateFolder Server.MapPath(InstallDir)
    If fso.FolderExists(Server.MapPath(InstallDir & ChannelDir)) = False Then fso.CreateFolder Server.MapPath(InstallDir & ChannelDir)
    SavePath = InstallDir & ChannelDir & "/" & UploadDir        '文件保存的本地路径
    If fso.FolderExists(Server.MapPath(SavePath)) = False Then fso.CreateFolder Server.MapPath(SavePath)
    SavePath = SavePath & "/"
    
    FileCount = 0
    SavedFiles = "|"
    tempi = 0
    regEx.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}([\w\-]+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(gif|jpg|jpeg|jpe|bmp|png)))"
    Set RemoteFiles = regEx.Execute(strContent)

    Dim AddWatermark, AddThumb, IsThumb
    If Trim(Request.Form("AddWatermark")) = "Yes" Then
        AddWatermark = True
    Else
        AddWatermark = False
    End If
    If Trim(Request.Form("AddThumb")) = "Yes" Then
        AddThumb = True
    Else
        AddThumb = False
    End If
    

    For Each RemoteFile In RemoteFiles
        IsThumb = False
        RemoteFileUrl = RemoteFile.value
        If InStr(SavedFiles, "|" & RemoteFileUrl & "|") > 0 Then
            '如果已经保存则不进行处理
        Else
            If FileCount = 0 Then
                Response.Write "<b>正在保存远程文件……请稍候！<font color='red'>在此过程中请勿刷新页面！</font></b> "
                Response.Flush
            End If

            SavedFiles = SavedFiles & RemoteFileUrl & "|"
            dtNow = Now()
            arrSaveFileName = Split(RemoteFileUrl, ".")
            SaveFileType = arrSaveFileName(UBound(arrSaveFileName))
            SavePath2 = Year(dtNow) & Right("0" & Month(dtNow), 2)
            If fso.FolderExists(Server.MapPath(SavePath & SavePath2)) = False Then fso.CreateFolder Server.MapPath(SavePath & SavePath2)
            SavePath2 = SavePath2 & "/"
            SaveFilePath = SavePath & SavePath2
            
            Randomize
            ranNum = Int(900 * Rnd) + 100
            temptime = 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
            SaveFileName = temptime & "." & SaveFileType
            ThumbFileName = temptime & "_S." & SaveFileType
            If SaveRemoteFile(RemoteFileUrl, SaveFilePath & SaveFileName) = True Then
                strContent = Replace(strContent, RemoteFileUrl, "[InstallDir_ChannelDir]{$UploadDir}/" & SavePath2 & SaveFileName)
                If PhotoObject = 1 Then
                    Dim PE_Thumb
                    Set PE_Thumb = New CreateThumb
                    If tempi = 0 And AddThumb = True Then
                        If PE_Thumb.CreateThumb(SaveFilePath & SaveFileName, SaveFilePath & ThumbFileName, 0, 0) = True Then
                            IsThumb = True
                        End If
                    End If