commonfunction.bas

用于局域网中的文件自动更新下载

Attribute VB_Name = "CommonFunction"
Option Explicit

' dom object
Private objDomDocument As DOMDocument

''''''''''''''''''''''''''''''''''''
'' send the command
''''''''''''''''''''''''''''''''''''
Public Function SendCommand(ByVal sXmlCommand As String) As String
    Dim objCommandElement As IXMLDOMElement
    Dim objRootElement    As IXMLDOMElement
    
    ' Init dom object
    Set objDomDocument = New DOMDocument
    ' create the root element
    Set objRootElement = objDomDocument.createElement(COMMANDS_TAG)
    ' create the command to get the new update files
    Set objCommandElement = CreateNode(objRootElement, COMMAND_TAG, _
            sXmlCommand)
    ' add to the dom object
    objDomDocument.appendChild objRootElement
    
    SendCommand = objDomDocument.xml
    
    Set objRootElement = Nothing
    Set objCommandElement = Nothing
    Set objDomDocument = Nothing
End Function

''''''''''''''''''''''''''''''''''''
'' get the command from dom object
''''''''''''''''''''''''''''''''''''
Public Function GetCommand(ByVal sXmlCommand As String) As String

    Dim objRootElement As IXMLDOMElement
    Dim sCommand       As String
    
    ' init the dom object
    Set objDomDocument = New DOMDocument
    
    ' load the xml command
    objDomDocument.loadXML sXmlCommand
    
    ' get the root element
    Set objRootElement = GetRootNode(objDomDocument, COMMANDS_TAG)
    
    ' get command string
    sCommand = GetNodeValue(objRootElement, COMMAND_TAG)
    
    ' return the command
    GetCommand = sCommand
    
    ' release the variable
    Set objRootElement = Nothing
    Set objDomDocument = Nothing
End Function

''''''''''''''''''''''''''''''''''''
'' Add a new node to the indicated objParentNode node.
''''''''''''''''''''''''''''''''''''
Private Function CreateNode(ByVal objParentNode As IXMLDOMNode, _
                           ByVal sNodeName As String, _
                           Optional sNodeValue As String = "") As IXMLDOMNode

    Dim objNewNode As IXMLDOMNode

    ' Create the new node.
    Set objNewNode = objParentNode.ownerDocument.createElement(sNodeName)

    ' Set the node's text value.
    If sNodeValue <> "" Then
        objNewNode.Text = sNodeValue
    End If

    ' Add the node to the objParentNode.
    objParentNode.appendChild objNewNode
    Set CreateNode = objNewNode
    
    ' release the variable
    Set objParentNode = Nothing
    Set objNewNode = Nothing
End Function

''''''''''''''''''''''''''''''''''''
'' Return the root node element
''''''''''''''''''''''''''''''''''''
Private Function GetRootNode(ByVal objDomDocument As DOMDocument, _
                            ByVal sRootNodeName As String) As IXMLDOMNode

    Dim objRootNode As IXMLDOMNode

    ' get the root node element by node name
    Set objRootNode = objDomDocument.selectSingleNode(".//" & sRootNodeName)
    
    If Not objRootNode Is Nothing Then
        Set GetRootNode = objRootNode
    End If

    ' release the variable
    Set objRootNode = Nothing
End Function

''''''''''''''''''''''''''''''''''''
'' Return the node value. Only for single node
''''''''''''''''''''''''''''''''''''
Private Function GetNodeValue(ByVal objStartAtNode As IXMLDOMNode, _
                             ByVal sNodeName As String) As String

    Dim objValueNode As IXMLDOMNode

    ' get the node value by node name
    Set objValueNode = objStartAtNode.selectSingleNode(".//" & sNodeName)

    If Not objValueNode Is Nothing Then
        GetNodeValue = objValueNode.Text
    End If
    
    ' release the variable
    Set objValueNode = Nothing
End Function

''''''''''''''''''''''''''''''''''''
'' Return the node list
''''''''''''''''''''''''''''''''''''
Private Function GetNodes(ByVal objNode As IXMLDOMNode, _
                         ByVal sNodeName As String) As IXMLDOMNodeList

    Dim objNodeList As IXMLDOMNodeList

    ' get the node list by node name
    Set objNodeList = objNode.selectNodes(".//" & sNodeName)
    
    ' return the node list
    Set GetNodes = objNodeList
    
    ' release the variable
    Set objNodeList = Nothing
End Function

' Get the files' infomation
Public Function GetLocalFileInfo(ByVal sPath As String) As Collection
    Dim objFso      As Scripting.FileSystemObject
    Dim objFolder   As Folder

    'Dim objSubFolder As Folder
    Dim objFile     As File
    Dim objFileInfo As FILEINFO
    Dim colFileInfo As Collection
    
    If sPath = "" Then sPath = objSystemInfo.sAppPath
    If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

    Set colFileInfo = New Collection
    Set objFso = New Scripting.FileSystemObject
    Set objFolder = objFso.GetFolder(sPath)

    For Each objFile In objFolder.Files

        Set objFileInfo = New FILEINFO
        objFileInfo.sFileName = objFile.Name
        objFileInfo.sFileSize = objFile.Size
        objFileInfo.sModifiedDate = objFile.DateLastModified
        colFileInfo.Add objFileInfo
    Next

    ' sub folder
    '    If objFolder.SubFolders.Count > 0 Then
    '        For Each sfd In obFd.SubFolders
    '            Call getFilenm(sfd.Path)
    '        Next
    '    End If
    Set GetLocalFileInfo = colFileInfo
    
    Set objFileInfo = Nothing
    Set colFileInfo = Nothing
    Set objFile = Nothing
    Set objFolder = Nothing
    Set objFso = Nothing
End Function

Public Function GetRemoteFileInfo(ByVal sUpdateInfo As String) As Collection

    ' the child elements' list
    Dim colNodeList     As IXMLDOMNodeList

    ' root element
    Dim objRootElement  As IXMLDOMElement

    ' child element
    Dim objChildElement As IXMLDOMElement
    Dim objFileInfo     As FILEINFO
    Dim colFileInfo     As Collection

    ' init the file info
    Set colFileInfo = New Collection
    
    Set objDomDocument = New DOMDocument
    objDomDocument.loadXML sUpdateInfo
    
    Set objRootElement = GetRootNode(objDomDocument, FILE_ROOT_ELEMENT)
    Set colNodeList = GetNodes(objRootElement, FILE_ELEMENT)
    
    If Not colNodeList Is Nothing Then
        For Each objChildElement In colNodeList
    
            Set objFileInfo = New FILEINFO
            objFileInfo.sFileName = GetNodeValue(objChildElement, FILENAME_ELEMENT)
            objFileInfo.sModifiedDate = GetNodeValue(objChildElement, _
                    MODIFIEDDATE_ELEMENT)
            objFileInfo.sFileSize = GetNodeValue(objChildElement, FILESIZE_ELEMENT)
            ' add the file info to the collection
            colFileInfo.Add objFileInfo
        Next
    End If

    Set GetRemoteFileInfo = colFileInfo
    Set objDomDocument = Nothing
    Set colNodeList = Nothing
    Set objRootElement = Nothing
    Set objChildElement = Nothing
    Set objFileInfo = Nothing
    Set colFileInfo = Nothing
End Function

Public Function GetUpdateFile(colLocalFileInfo As Collection, _
                              colRemoteFileInfo As Collection) As Collection

    Dim objLocalFileInfo  As FILEINFO
    Dim objRemoteFileInfo As FILEINFO
    Dim colUpdateFile     As Collection

    For Each objLocalFileInfo In colLocalFileInfo

        For Each objRemoteFileInfo In colRemoteFileInfo

            ' if it was the same file
            If objLocalFileInfo.sFileName = objRemoteFileInfo.sFileName Then
                ' the file was exist
                objRemoteFileInfo.bFileExist = True

                If objLocalFileInfo.sFileSize <> objRemoteFileInfo.sFileSize _
                        Then
                    'objLocalFileInfo.sModifiedDate <> objRemoteFileInfo.sModifiedDate Or
                    objRemoteFileInfo.bUpdate = True
                End If
            End If

        Next
    Next

    Set colUpdateFile = New Collection

    For Each objRemoteFileInfo In colRemoteFileInfo

        If objRemoteFileInfo.bFileExist = False Or objRemoteFileInfo.bUpdate _
                = True Then
                objRemoteFileInfo.sFileName = URLEncode(objRemoteFileInfo.sFileName)
            colUpdateFile.Add objRemoteFileInfo
        End If

    Next

    Set GetUpdateFile = colUpdateFile
    Set colUpdateFile = Nothing
    Set objRemoteFileInfo = Nothing
    Set objLocalFileInfo = Nothing
End Function

Public Function GenerateUpdateXml(ByVal colFileInfo As Collection) As String

    Dim objFileInfo    As FILEINFO
    Dim objRootElement As IXMLDOMElement
    Dim objChileNode   As IXMLDOMNode

    Set objDomDocument = New DOMDocument
    ' Create the root element
    Set objRootElement = objDomDocument.createElement(FILE_ROOT_ELEMENT)

    ' Create the child nodes
    For Each objFileInfo In colFileInfo

        Set objChileNode = CreateNode(objRootElement, FILE_ELEMENT)
        CreateNode objChileNode, FILENAME_ELEMENT, objFileInfo.sFileName
        CreateNode objChileNode, MODIFIEDDATE_ELEMENT, objFileInfo.sModifiedDate
        CreateNode objChileNode, FILESIZE_ELEMENT, objFileInfo.sFileSize
    Next

    objDomDocument.appendChild objRootElement
    GenerateUpdateXml = objDomDocument.xml
    
    Set objDomDocument = Nothing
    Set objChileNode = Nothing
    Set objRootElement = Nothing
    Set objFileInfo = Nothing
End Function

Public Function URLDecode(sEncodedURL As String) As String
    On Error GoTo Catch
    
    Dim iLoop As Integer
    Dim sRtn As String
    Dim sTmp As String
    


    If Len(sEncodedURL) > 0 Then

        For iLoop = 1 To Len(sEncodedURL)
            sTmp = Mid(sEncodedURL, iLoop, 1)
            sTmp = Replace(sTmp, "+", " ")

            If sTmp = "%" And Len(sEncodedURL) > iLoop + 2 Then
                sTmp = Mid(sEncodedURL, iLoop + 1, 2)
                sTmp = Chr(CDec("&H" & sTmp))
                iLoop = iLoop + 2
            End If
            sRtn = sRtn & sTmp
        Next iLoop
        URLDecode = sRtn
    End If
Finally:
    Exit Function
Catch:
    URLDecode = ""
    Resume Finally
End Function

Option Explicit

Public Function URLEncode(ByVal input_url As String) As String
   Dim count As Long
   Dim one_char As String
   URLEncode = ""


   For count = 1 To Len(input_url)
       one_char = Mid$(input_url, count, 1)


       If InStr("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", UCase$(one_char)) = 0 Then
           one_char = "%" & Right$("0" & Hex$(Asc(one_char)), 2)
       End If
       URLEncode = URLEncode & one_char
   Next
End Function