xmlconfig.cls

INI_to_XML,XML文件操作,VB源程序.想学习XML编程的朋友可以下载试试.

    
    'setup the document for access
    Set oBlocks = moDoc.selectNodes(mCONFIG)

    If oBlocks.length = 0 Then
        CreateConfigure
    End If
    
    Set oBlocks = moDoc.selectNodes(mBLOCK)
    
    If oBlocks.length = 0 Then
        CreateSection
        SectionDescription = sValue
    End If
    
    'iterate through the blocks until we find the correct section and key
    For Each oBlock In oBlocks
        If oBlock.Attributes(mAttrNameID).Text = msSection Then
            oBlock.Attributes(mAttrValueID).Text = sValue
            moDoc.save msFilename
            Exit Property
        End If
    Next oBlock
    
ExitProc:
    Exit Property
ErrHandler:
    Debug.Print Err.Description
    Resume ExitProc
End Property

'****************************************************************************************
'METHODS - PUBLIC
'****************************************************************************************
Public Sub DeleteKey()
    On Error GoTo ErrHandler
    
    Dim oBlock As MSXML2.IXMLDOMNode
    Dim oBlocks As MSXML2.IXMLDOMNodeList
    Dim oNode As MSXML2.IXMLDOMNode
    Dim oNodes As MSXML2.IXMLDOMNodeList

    'setup the document for access
    Set oBlocks = moDoc.selectNodes(mBLOCK)

    'iterate through the blocks until we find the correct section
    For Each oBlock In oBlocks
        If oBlock.Attributes(mAttrNameID).Text = msSection Then
            Set oNodes = oBlock.childNodes

            If oNodes.length <> 0 Then
                For Each oNode In oNodes
                    If oNode.Attributes(mAttrNameID).Text = msKey Then
                        'delete the key and save the file
                        oNode.parentNode.removeChild oNode
                        moDoc.save msFilename
                        Exit For
                    End If
                Next oNode
            End If
            Exit For
        End If
    Next oBlock

ExitProc:
    Exit Sub
ErrHandler:
    Debug.Print Err.Description
    Resume ExitProc
End Sub

Public Sub DeleteSection()
    On Error GoTo ErrHandler
    
    Dim oBlock As MSXML2.IXMLDOMNode
    Dim oBlocks As MSXML2.IXMLDOMNodeList
    
    Set oBlocks = moDoc.selectNodes(mBLOCK)

    'iterate through the blocks until we find the correct section
    For Each oBlock In oBlocks
        If oBlock.Attributes(mAttrNameID).Text = msSection Then
            'delete the section and save the file
            oBlock.parentNode.removeChild oBlock
            moDoc.save msFilename
        End If
    Next oBlock

ExitProc:
    Exit Sub
ErrHandler:
    Debug.Print Err.Description
    Resume ExitProc
End Sub

Public Sub EnumerateCurrentSection(ByRef sKey() As String, ByRef lCount As Long)
    On Error GoTo ErrHandler
    
    Dim oBlock As MSXML2.IXMLDOMNode
    Dim oBlocks As MSXML2.IXMLDOMNodeList
    Dim oNode As MSXML2.IXMLDOMNode
    Dim oNodes As MSXML2.IXMLDOMNodeList
    
    Set oBlocks = moDoc.selectNodes(mBLOCK)
    
    'iterate through the blocks until we find the correct section
    For Each oBlock In oBlocks
        If oBlock.baseName = mSECTION Then
            If oBlock.Attributes(mAttrNameID).Text = msSection Then
                Erase sKey
                lCount = 0
                Set oNodes = oBlock.childNodes

                If oNodes.length <> 0 Then
                    For Each oNode In oNodes
                        'resize the array and set the key name
                        If oNode.baseName = mKEY Then
                            lCount = lCount + 1
                            ReDim Preserve sKey(1 To lCount) As String
                            sKey(UBound(sKey)) = oNode.Attributes(mAttrNameID).Text
                        End If
                    Next oNode
                End If
                Exit For
            End If
        End If
    Next oBlock

ExitProc:
    On Error Resume Next
    Exit Sub
ErrHandler:
    Debug.Print Err.Number & ": " & Err.Description
    Resume ExitProc
End Sub

Public Sub EnumerateAllSections(ByRef sSection() As String, ByRef lCount As Long)
    On Error GoTo ErrHandler
    
    Dim oBlock As MSXML2.IXMLDOMNode
    Dim oBlocks As MSXML2.IXMLDOMNodeList
    Dim lSection As Long
    
    Set oBlocks = moDoc.selectNodes(mBLOCK)

    If oBlocks.length = 0 Then
        CreateConfigure
    End If
    
    Erase sSection
    lCount = 0
    
    'iterate through the blocks and set the section name
    For Each oBlock In oBlocks
        If oBlock.baseName = mSECTION Then
            lCount = lCount + 1
            ReDim Preserve sSection(1 To lCount) As String
            sSection(UBound(sSection)) = oBlock.Attributes(mAttrNameID).Text
        End If
    Next oBlock

ExitProc:
    On Error Resume Next
    Exit Sub
ErrHandler:
    Debug.Print Err.Number & ": " & Err.Description
    Resume ExitProc
End Sub

Public Function IniToXml(ByRef INIFile As String, Optional ByRef XMLFile As String = vbNullString) As Long
    'Code in this routine is based on code from Pamela RAI and the resulting XML
    'file is based on Pamelas format with the addition of the Description attribute
    'and the code for the processing instructions
    'http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=48510&lngWId=1
    'The exception is that I am using the DOMDocument object to create the XML file
    'instead of opening a file and writing strings to it, but the methodology is pretty
    'much the same
    Dim oKey As MSXML2.IXMLDOMNode
    
    Dim lpSections As String
    Dim nSize As Long
    Dim nMaxSize As Long
    Dim sSections() As String
    Dim lSection As Long
    Dim lpKeys As String
    Dim sKeys() As String
    Dim lKey As Long
    Dim sValues() As String
    
    If XMLFile = vbNullString Then
        If msFilename = vbNullString Or IsMissing(XMLFile) Then
            ' set the XML's file name based on the INI file name
            'in this case we simply add .xml to the end of the INI filename
            'ie. Sample.ini will become sample.ini.xml
            XMLFile = INIFile & ".xml"
        Else
            'if the person has already set a path for the file then use that
            XMLFile = msFilename
        End If
    End If

    ' Get all sections names
    ' Making sure allocate enough space for data returned
    nMaxSize = INITIAL_BUFFER_SIZE / 2
    Do
        nMaxSize = nMaxSize * 2
        lpSections = Space$(nMaxSize)
        nSize = GetPrivateProfileSectionNames(lpSections, nMaxSize, INIFile)
    Loop Until nSize = 0 Or nSize < nMaxSize - 2
    
    sSections() = Split(lpSections, Chr(0))
    
    'create the main "Configuration" element
    CreateConfigure
    
    'get key names within the sections
    For lSection = LBound(sSections) To UBound(sSections)
        If (TrimNull(sSections(lSection)) <> vbNullString) Then
            'create the "Section" node and its attributes
            msSection = sSections(lSection)
            Set oKey = CreateSection
            
            'now get the key names and values in the section
            nMaxSize = INITIAL_BUFFER_SIZE / 2
            Do
                nMaxSize = nMaxSize * 2
                lpKeys = Space$(nMaxSize)
                nSize = GetPrivateProfileSection(sSections(lSection), lpKeys, nMaxSize, INIFile)
            Loop Until nSize = 0 Or nSize < nMaxSize - 2
            
            sKeys() = Split(lpKeys, Chr(0))
            For lKey = LBound(sKeys) To UBound(sKeys)
                If (TrimNull(sKeys(lKey)) <> vbNullString) Then
                    sValues() = Split(sKeys(lKey), "=")
                    'now set the attributes
                    msKey = sValues(mAttrNameID)
                    CreateKeyValue oKey, sValues(mAttrValueID)
                End If
            Next lKey
        End If
    Next lSection
    moDoc.save XMLFile
    
    IniToXml = True

End Function

'****************************************************************************************
'METHODS - PRIVATE
'****************************************************************************************
Private Sub CreateKeyValue(ByRef oParent As IXMLDOMNode, Optional ByRef sValue As String, Optional ByRef sDesc As String)
    Dim oNode As MSXML2.IXMLDOMNode
    Dim oAttr As MSXML2.IXMLDOMNode
        
    Set oNode = moDoc.createNode(NODE_ELEMENT, mKEY, vbNullString)
    oParent.appendChild oNode
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, mAttrName, vbNullString)
    oNode.Attributes.setNamedItem oAttr
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, mAttrValue, vbNullString)
    oNode.Attributes.setNamedItem oAttr
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, mAttrDesc, vbNullString)
    oNode.Attributes.setNamedItem oAttr
    oNode.Attributes(mAttrNameID).Text = msKey
    If sValue <> vbNullString Then
        oNode.Attributes(mAttrValueID).Text = sValue
    End If
    If sDesc <> vbNullString Then
        oNode.Attributes(mAttrDescID).Text = sDesc
    End If
End Sub

Private Function CreateSection() As IXMLDOMNode
    Dim oBlock As MSXML2.IXMLDOMNode
    Dim oNode As MSXML2.IXMLDOMNode
    Dim oAttr As MSXML2.IXMLDOMNode

    Set oBlock = moDoc.selectSingleNode(mCONFIG)
    Set oNode = moDoc.createNode(NODE_ELEMENT, mSECTION, vbNullString)
    oBlock.appendChild oNode
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, mAttrName, vbNullString)
    oNode.Attributes.setNamedItem oAttr
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, mAttrDesc, vbNullString)
    oNode.Attributes.setNamedItem oAttr
    oNode.Attributes(mAttrNameID).Text = msSection
    Set CreateSection = oNode
End Function

Private Sub CreateConfigure()
    Dim oNode As MSXML2.IXMLDOMNode
    Dim oAttr As MSXML2.IXMLDOMAttribute
    
    On Error Resume Next
    'add processing information - this is in case we decide later to go with
    'different versions of the xml format and need to support the different
    'formats
    Set oNode = moDoc.createNode(NODE_PROCESSING_INSTRUCTION, "xml", vbNullString)
    moDoc.appendChild oNode
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, "version", vbNullString)
    oNode.Attributes.setNamedItem oAttr
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, "encoding", vbNullString)
    oNode.Attributes.setNamedItem oAttr
    Set oAttr = moDoc.createNode(NODE_ATTRIBUTE, "standalone", vbNullString)
    oNode.Attributes.setNamedItem oAttr
    oNode.Attributes(0).Text = "1.0"
    oNode.Attributes(1).Text = "UTF-8"
    oNode.Attributes(2).Text = "yes"
    'finally add the configuration node
    Set oNode = moDoc.createNode(NODE_ELEMENT, mCONFIG, vbNullString)
    moDoc.appendChild oNode
    moDoc.save msFilename
    
End Sub

Private Function TrimNull(ByVal StrIn As String) As String
    'this routine was obtained from Karl Peterson's web site - it is used in several
    'of his samples
    'http://vb.mvps.org/
   Dim nul As Long
   '
   ' Truncate input string at first null.
   ' If no nulls, perform ordinary Trim.
   '
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         TrimNull = Left$(StrIn, nul - 1)
      Case 1
         TrimNull = ""
      Case 0
         TrimNull = Trim$(StrIn)
   End Select
End Function