func.asp

WAPmo手机网站管理平台是一款创建与管理维护WAP网站的的软件产品

<%
Public Function GetPathName(ByVal strPath)
    If Left(strPath, 1) = "/" Then
        GetPathName = strPath
    Else
        GetPathName = WM_Home & strPath
    End If
End Function

Public Function GetMapPath(ByVal strPath)
    GetMapPath = Server.MapPath(GetPathName(strPath))
End Function

Public Function GetCodePage(ByVal strCharset)
    Dim xmlDoc
    Dim xmlNode
    Dim strName
    strName = "WAPmo.Codepage"
    If IsEmpty(GetCache(strName)) Then
        Set xmlDoc = xml.cloneNode(True)
        xmlDoc.async = False
        If Not xmlDoc.Load(GetMapPath("config/codepage.xml")) Then
            Err.Raise moErrorMissingCodepage, "GetCodePage", "Invalid xml: " & xmlDoc.parseError.reason
        End If
        SetCache strName, xmlDoc
    Else
        Set xmlDoc = GetCache(strName).cloneNode(True)
    End If
    Set xmlNode = xmlDoc.selectSingleNode("/root/codepage[@name='" & XPathString(UCase(strCharset)) & "']")
    If xmlNode Is Nothing Then
        GetCodePage = WAPMO_CODEPAGE
    Else
        GetCodePage = CLng(xmlNode.getAttribute("value"))
    End If
    Set xmlDoc = Nothing
End Function

Public Function GetCharset(ByVal lngCodePage)
    Dim xmlDoc
    Dim xmlNode
    Dim strName
    strName = "WAPmo.Codepage"
    If IsEmpty(GetCache(strName)) Then
        Set xmlDoc = xml.cloneNode(True)
        xmlDoc.async = False
        If Not xmlDoc.Load(GetMapPath("config/codepage.xml")) Then
            Err.Raise moErrorMissingCodepage, "GetCharset", "Invalid xml: " & xmlDoc.parseError.reason
        End If
        SetCache strName, xmlDoc
    Else
        Set xmlDoc = GetCache(strName).cloneNode(True)
    End If
    Set xmlNode = xmlDoc.selectSingleNode("/root/codepage[@value=" & lngCodePage & "]")
    If xmlNode Is Nothing Then
        GetCharset = WAPMO_CHARSET
    Else
        GetCharset = xmlNode.getAttribute("name")
    End If
    Set xmlDoc = Nothing
End Function

Public Function GetPersistXSLT(ByVal strParent, ByVal strChild)
    Dim xmlDoc, strName
    Dim xmlNode
    strName = "WAPmo.Persist"
    If VarType(GetCache(strName)) <> vbObject Then
        Set xmlDoc = xml.cloneNode(True)
        xmlDoc.async = False
        If Not xmlDoc.Load(GetMapPath("config/persist.xsl")) Then
            Err.Raise vbObjectError + 1, "DB.GetPersistXSLT", "Invalid xslt file: " & xmlDoc.parseError.reason
        End If
        SetCache strName, xmlDoc
        Set xmlDoc = Nothing
    End If
    Set xmlDoc = GetCache(strName).cloneNode(True)
    Set xmlNode = xmlDoc.selectSingleNode("xsl:stylesheet/xsl:template/xsl:element")
    xmlNode.setAttribute "name", strParent
    Set xmlNode = Nothing
    Set xmlNode = xmlDoc.selectSingleNode("xsl:stylesheet/xsl:template/xsl:element/xsl:for-each/xsl:element")
    xmlNode.setAttribute "name", strChild
    Set xmlNode = Nothing
    Set GetPersistXSLT = xmlDoc
    Set xmlDoc = Nothing
End Function

Public Function RecordToXML(ByVal rs, ByVal lngRows, ByVal strParent, ByVal strChild)
    Dim xmlDoc, xslDoc
    Dim xmlParent, xmlChild
    Dim objField, i
    If lngRows = adGetRowsRest Then
        Set xmlDoc = xml.cloneNode(True)
        Set xslDoc = GetPersistXSLT(strParent, strChild)
        Set RecordToXML = xml.cloneNode(True)
        xmlDoc.async = False
        RecordToXML.async = False
        rs.Save xmlDoc, adPersistXML
        xmlDoc.transformNodeToObject xslDoc, RecordToXML
        Set xslDoc = Nothing
        Set xmlDoc = Nothing
    Else
        Set RecordToXML = xml.cloneNode(True)
        RecordToXML.appendChild RecordToXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
        i = 0
        Set xmlParent = RecordToXML.appendChild(RecordToXML.createElement(strParent))
        Do While Not rs.EOF And i < lngRows
            Set xmlChild = xmlParent.appendChild(RecordToXML.createElement(strChild))
            For Each objField In rs.Fields
                xmlChild.setAttribute LCase(objField.Name), IIf(IsNull(objField.Value), "", objField.Value)
            Next
            Set xmlChild = Nothing
            rs.MoveNext
            i = i + 1
        Loop
        Set xmlParent = Nothing
    End If
End Function

Public Function GetMatterCategory(ByVal strExt)
    If InString(MyKernel.Config("AllowImage"), strExt, False) Then
        GetMatterCategory = wmTypeImage
    ElseIf InString(MyKernel.Config("AllowRing"), strExt, False) Then
        GetMatterCategory = wmTypeRing
    ElseIf InString(MyKernel.Config("AllowVideo"), strExt, False) Then
        GetMatterCategory = wmTypeVideo
    ElseIf InString(MyKernel.Config("AllowSoft"), strExt, False) Then
        GetMatterCategory = wmTypeSoft
    Else
        GetMatterCategory = 0
    End If
End Function

Private Function GetMatterName(ByVal intCate)
    Select Case atoi(intCate)
    Case wmTypeImage
        GetMatterName = "image"
    Case wmTypeRing
        GetMatterName = "ring"
    Case wmTypeVideo
        GetMatterName = "video"
    Case wmTypeSoft
        GetMatterName = "soft"
    Case Else
        GetMatterName = ""
    End Select
End Function

Private Function GetMatterNameX(ByVal intCate)
    Select Case atoi(intCate)
    Case wmTypeImage
        GetMatterNameX = "图片"
    Case wmTypeRing
        GetMatterNameX = "铃声"
    Case wmTypeVideo
        GetMatterNameX = "视频"
    Case wmTypeSoft
        GetMatterNameX = "软件"
    Case Else
        GetMatterNameX = ""
    End Select
End Function

Public Sub CheckMatterFolder(ByVal intCate, ByVal lngTime)
    DetectFolder GetMapPath(""), str_format("images/$0/$1", Array(GetMatterName(intCate), FormatTime(lngTime, "Ymd")))
End Sub

Public Function GetMatterFile(ByVal intCate, ByVal lngTime, ByVal lngMark, ByVal strExt, ByVal strSuffix)
    Dim strPath, arr(4)
    arr(0) = GetMatterName(intCate)
    arr(1) = FormatTime(lngTime, "Ymd")
    arr(2) = Hex(atol(lngMark))
    arr(3) = LCase(strExt)
    arr(4) = strSuffix
    If strSuffix = "" Then
        strPath = str_format("images/$0/$1/$2.$3", arr)
    Else
        strPath = str_format("images/$0/$1/$2$4.$3", arr)
    End If
    GetMatterFile = GetPathName(strPath)
End Function

Public Function GetMatterPath(ByVal intCate, ByVal lngTime, ByVal lngMark, ByVal strExt, ByVal strSuffix)
    GetMatterPath = GetMapPath(GetMatterFile(intCate, lngTime, lngMark, strExt, strSuffix))
End Function

Public Function ImageConvert(ByVal strSrc, ByVal strDst)
    Dim strExt1, strExt2
    Dim objImg
    strExt1 = LCase(fso.GetExtensionName(strSrc))
    strExt2 = LCase(fso.GetExtensionName(strDst))
    If Not fso.FileExists(strSrc) Then
        ImageConvert = False
    ElseIf strExt1 = strExt2 Then
        fso.CopyFile strSrc, strDst
        ImageConvert = True
    Else
        On Error Resume Next
        Set objImg = Server.CreateObject("ImageMagickObject.MagickImage")
        If strExt1 = "gif" And strExt2 <> "gif" Then
            objImg.Convert strSrc & "[0]", strDst
        Else
            objImg.Convert strSrc, strDst
        End If
        Set objImg = Nothing
        ImageConvert = CBool(Err.Number = 0)
        If Err.Number Then Err.Clear
    End If
End Function

'图片重设尺寸并保存到另一个文件
Public Function ImageResize(ByVal strPath, ByVal strDest, ByVal w, ByVal h)
    Dim objImg
    Dim strExt1, strExt2
    strExt1 = LCase(fso.GetExtensionName(strPath))
    strExt2 = LCase(fso.GetExtensionName(strDest))
    On Error Resume Next
    Set objImg = Server.CreateObject("ImageMagickObject.MagickImage")
    If strExt1 = "gif" And strExt2 <> "gif" Then
        objImg.Convert "-resize", "" & w & "x" & h & "", strPath & "[0]", strExt2 & ":" & strDest
    Else
        objImg.Convert "-resize", "" & w & "x" & h & "", strPath, strExt2 & ":" & strDest
    End If
    Set objImg = Nothing
    ImageResize = CBool(Err.Number = 0)
End Function

'图片转换格式
Public Function ImageConvert(ByVal strPath, ByVal strDest)
    Dim objImg
    Dim strExt1, strExt2
    ImageConvert = True
    If LCase(strPath) = LCase(strDest) Then Exit Function
    strExt1 = LCase(fso.GetExtensionName(strPath))
    strExt2 = LCase(fso.GetExtensionName(strDest))
    If strExt1 = strExt2 Then
        fso.CopyFile strPath, strDest, True
    Else
        On Error Resume Next
        Set objImg = Server.CreateObject("ImageMagickObject.MagickImage")
        If strExt1 = "gif" And strExt2 <> "gif" Then
            objImg.Convert strPath & "[0]", strDst
        Else
            objImg.Convert strPath, strDst
        End If
        Set objImg = Nothing
        ImageConvert = CBool(Err.Number = 0)
    End If
End Function

'图片重设尺寸并保存到另一个文件，根据最大的宽高重设尺寸，当原尺寸超过最大宽高，则转为最大宽高的图片，否则，按原图拷贝到目标地址
Public Function ImageResize2(ByVal strPath, ByVal strDest, ByVal intMaxWidth, ByVal intMaxHeight)
    Dim info, w, h
    info = GetFileInfo(strPath)
    w = info(1)
    h = info(2)
    If w > 0 And h > 0 Then
        If w > intMaxWidth Or h > intMaxHeight Then
            ImageResize2 = ImageResize4(strPath, strDest, w, h, intMaxWidth, intMaxHeight)
        Else
            ImageResize2 = Array(ImageConvert(strPath, strDest), w, h)
        End If
    Else
        ImageResize2 = Array(False, 0, 0)
    End If
End Function

'图片重设尺寸并保存到另一个文件，不做任何判断，将图片重设为最大宽高的图片
Public Function ImageResize3(ByVal strPath, ByVal strDest, ByVal intMaxWidth, ByVal intMaxHeight)
    Dim info, w, h
    info = GetFileInfo(strPath)
    w = info(1)
    h = info(2)
    If w > 0 And h > 0 Then
        ImageResize3 = ImageResize4(strPath, strDest, w, h, intMaxWidth, intMaxHeight)
    Else
        ImageResize3 = Array(False, 0, 0)
    End If
End Function

'图片重设尺寸并保存到另一个文件，根据原图尺寸和最大宽高的比例将图片重设尺寸
Public Function ImageResize4(ByVal strPath, ByVal strDest, ByVal w, ByVal h, ByVal intMaxWidth, ByVal intMaxHeight)
    Dim dblPW, dblPH, dblPC
    Dim dblRW, dblRH
    dblPW = intMaxWidth / w
    dblPH = intMaxHeight / h
    dblPC = IIf(dblPW > dblPH, dblPH, dblPW)
    dblRW = CInt(dblPC * w)
    dblRH = CInt(dblPC * h)
    ImageResize4 = Array(ImageResize(strPath, strDest, dblRW, dblRH), dblRW, dblRH)
End Function

Public Sub ImageImpress(ByVal strPath)
    On Error Resume Next
    Dim objImg
    Select Case MyKernel.Config("impress")
    Case "1"
        Set objImg = Server.CreateObject("ImageMagickObject.MagickImage")
        objImg.Convert "-font", MyKernel.Config("impress_font"), "-pointsize", MyKernel.Config("impress_size"), "-gravity", MyKernel.Config("impress_place"), "-fill", MyKernel.Config("impress_color"), "-draw", "text " & MyKernel.Config("impress_x") & "," & MyKernel.Config("impress_y") & " '" & MyKernel.Config("impress_text") & "'", strPath, strPath