vb 如何使用动态创建xml文件

以下是自己以前写的vb 读写操作xml 完正的类模块,

我的和讯http://hexun.com/haoguoying
我的百度http://hi.baidu.com/haoguoying/home

 

Option Explicit

Public name As String       '目录名称
Public val As String        '只有在是叶子的时候才有用

Private Ctree() As cls_Tree         '本目录的下级目录
Private Cyezi() As cls_Tree          '本目录的叶子

Public filename As String
'第一个不能用

'Private Sub Class_Initialize()
'
'End Sub

Private Sub Class_Terminate()
    Erase Ctree
    Erase Cyezi
End Sub

'删除一个叶子，如果NAME为空则删除一个目录
Public Function Delyezi(ByVal path As String, ByVal name As String) As Boolean

    ''on error Resume Next
    Dim i       As Integer

    Dim cnt1 As Integer

    Dim node As cls_Tree

    Dim t1() As String

    Dim child() As cls_Tree

    Dim count As Integer

    path = Replace(Trim(Replace(path, "/", " ")), " ", "/") '把两边的/全去掉
   
    t1 = Split(path, "/")

    If Len(path) = 0 Then
        If ZBound(Cyezi) = -1 Then Exit Function                  '没有就不用删除了

        For count = 0 To ZBound(Cyezi)

            'If Cyezi(count).name = t1(0) Then
            If Cyezi(count).name = name Then
                Set Cyezi(count) = Nothing

                Exit For

            End If

        Next

        If count > UBound(Cyezi) Then   '没有找到则退出

            Exit Function

        End If

        If UBound(Cyezi) = 0 Then   '最后一个了，因为不能删除，所以把它转成别的类型
            Erase Cyezi

            Exit Function

        End If

        ReDim child(UBound(Cyezi)) As cls_Tree

        For cnt1 = 0 To UBound(Cyezi)
            Set child(cnt1) = Cyezi(cnt1)
        Next

        ReDim Cyezi(UBound(Cyezi) - 1) As cls_Tree

        If UBound(Cyezi) <> -1 Then

            For cnt1 = 0 To count - 1
                Set Cyezi(cnt1) = child(cnt1)
            Next

            For cnt1 = count + 1 To UBound(child)
                Set Cyezi(cnt1 - 1) = child(cnt1)
            Next

            Exit Function

        End If
    End If

    path = Mid(path, Len(t1(0)) + 1, Len(path))

    If ZBound(Ctree) = -1 Then

        Exit Function           '没有就不用删除了

    Else

        For count = 0 To UBound(Ctree)

            If Ctree(count).name = t1(0) Then
                If Len(name) <> 0 Then '让它删记录去
                    Call Ctree(count).Delyezi(path, name)

                    Exit Function

                Else

                    If Len(path) = 0 Then '当前目录，则删除

                        Exit For

                    Else
                        Call Ctree(count).Delyezi(path, name)

                        Exit Function

                    End If
                End If
            End If

        Next

        If count > ZBound(Ctree) Then   '没有找到则退出

            Exit Function

        End If

        If ZBound(Ctree) < 0 Then
            Erase Ctree

            Exit Function

        End If

        ReDim child(ZBound(Ctree)) As cls_Tree

        For cnt1 = 0 To ZBound(Ctree)
            Set child(cnt1) = Ctree(cnt1)
        Next

        If ZBound(Ctree) = 0 Then
            Erase Ctree
        Else
            ReDim Ctree(UBound(Ctree) - 1) As cls_Tree

            If UBound(Ctree) <> -1 Then

                For cnt1 = 0 To count - 1
                    Set Ctree(cnt1) = child(cnt1)
                Next

                For cnt1 = count + 1 To UBound(child)
                    Set Ctree(cnt1 - 1) = child(cnt1)
                Next

            End If
        End If
    End If

End Function
'添加一个叶子，如果NAME为空，则添加一个目录
Public Function AddYezi(ByVal path As String, ByVal name As String, ByVal val As String) As cls_Tree
  ''on error Resume Next
    Dim i As Integer
    Dim node
    Dim childnode As cls_Tree
    Dim t1 As String
    Dim t2() As String
    Dim child() As cls_Tree
    Dim cnt1 As Integer
    Dim count As Integer
    path = Replace(Trim(Replace(path, "/", " ")), " ", "/") '把两边的/全去掉
   
    If Len(path) = 0 Then
        If Len(name) = 0 Then
            Set AddYezi = Me
            Exit Function
        End If
        If isnothing(Cyezi) = True Then
            ReDim Cyezi(0) As cls_Tree
        Else
            For cnt1 = 0 To UBound(Cyezi)
                If Cyezi(cnt1).name = name And Len(name) <> 0 Then
                    'AddYezi = Cyezi(cnt1).AddYezi(path, name, val)
                    Cyezi(cnt1).val = val
                    Exit Function
                End If
            Next
            ReDim child(UBound(Cyezi)) As cls_Tree
            For cnt1 = 0 To UBound(Cyezi)
                Set child(cnt1) = Cyezi(cnt1)
            Next
            ReDim Cyezi(UBound(Cyezi) + 1) As cls_Tree
            For cnt1 = 0 To UBound(child)
                Set Cyezi(cnt1) = child(cnt1)
            Next
        End If
        Set Cyezi(UBound(Cyezi)) = New cls_Tree
        Cyezi(UBound(Cyezi)).name = name
        Cyezi(UBound(Cyezi)).val = val
        Set AddYezi = Cyezi(UBound(Cyezi))
        Exit Function           '总返回
    End If
     t2 = Split(path, "/")
    t1 = t2(0)
    path = Mid(path, Len(t1) + 2, Len(path))
    If isnothing(Ctree) = True Then
        ReDim Ctree(0) As cls_Tree
    Else
        For cnt1 = 0 To UBound(Ctree)
            If Ctree(cnt1).name = t1 Then
                Set AddYezi = Ctree(cnt1).AddYezi(path, name, val)
                Exit Function
            End If
        Next
        ReDim child(UBound(Ctree)) As cls_Tree
        For cnt1 = 0 To UBound(Ctree)
            Set child(cnt1) = Ctree(cnt1)
        Next
        ReDim Ctree(UBound(Ctree) + 1) As cls_Tree
        For cnt1 = 0 To UBound(child)
            Set Ctree(cnt1) = child(cnt1)
        Next
    End If
    Set Ctree(UBound(Ctree)) = New cls_Tree
    Ctree(UBound(Ctree)).name = t1
    Set AddYezi = Ctree(UBound(Ctree)).AddYezi(path, name, val)
End Function
'查找一个记录，如果name为空认为是要反回这个目录' mo 为没有找到时返回的默认值（只对查找名称时有效）
Public Function FindYezi(ByVal path As String, ByVal name As String, ByVal mo As String) As Variant
  ' ''on error Resume Next
Dim i As Integer
Dim cnt1 As Integer
Dim node As cls_Tree
Dim t1() As String
Dim child() As cls_Tree
Dim count As Integer
    path = Replace(Trim(Replace(path, "/", " ")), " ", "/") '把两边的/全去掉
   
    t1 = Split(path, "/")
    If Len(path) = 0 Then
        If Len(name) = 0 Then '要这个目录的全部
            Dim ret() As String
            If isnothing(Cyezi) <> True Then
                ReDim ret(UBound(Cyezi), 1) As String
                For cnt1 = 0 To UBound(Cyezi)
                    ret(cnt1, 0) = Cyezi(cnt1).name
                    ret(cnt1, 1) = Cyezi(cnt1).val
                Next
            End If
            FindYezi = ret
            Exit Function
        End If
        If isnothing(Cyezi) = False Then
            For count = 0 To UBound(Cyezi)
                If Cyezi(count).name = name Then
                    FindYezi = Cyezi(count).val
                    Exit Function
                End If
            Next
        End If
        FindYezi = mo
        Exit Function
    End If
    path = Mid(path, Len(t1(0)) + 1, Len(path))
    If isnothing(Ctree) = True Then
       ' Me.AddYezi t1(0) & "/" & path, "", ""
       FindYezi = mo
       Exit Function
    End If
    For count = 0 To UBound(Ctree)
        If Ctree(count).name = t1(0) Then
                 FindYezi = Ctree(count).FindYezi(path, name, mo)
            Exit Function
        End If
    Next
    FindYezi = mo
    Exit Function
End Function
'从文件中读出
Public Function ReadFile(name As String) As Boolean
On Error Resume Next
Dim flbuff As String    '保存文件内容
Dim fp As Integer
    ReadFile = False
    If Len(name) = 0 Then name = filename
    If Len(name) = 0 Then Exit Function
    If Len(filename) = 0 Then filename = name
   
    fp = FreeFile
    Dim fpbuff As String
   
    flbuff = ""
    If FindFile(name) = "" Then Exit Function
    Open name For Input As fp
   
    Dim lbyte As String
    While EOF(fp) = False
        lbyte = Input(1, fp)
        If lbyte = """" Then
            flbuff = flbuff & lbyte
            Do While (1 Or EOF(fp) = False)
                lbyte = Input(1, fp)
                If lbyte = """" Then Exit Do
                flbuff = flbuff & lbyte
            Loop
        End If
        If lbyte <> vbTab And lbyte <> vbCr And lbyte <> Chr(10) And lbyte <> " " Then
            flbuff = flbuff & lbyte
        End If
    Wend
    Close fp
    ' 把没用的字符去掉
'    flbuff = Replace(flbuff, vbTab, "")'    flbuff = Replace(flbuff, vbCr, "")'    flbuff = Replace(flbuff, vbCrLf, "")'    flbuff = Replace(flbuff, Chr(10), "")
    flbuff = Mid(flbuff, InStr(1, flbuff, ">") + 1, Len(flbuff)) '去掉第一行的XML注释
    read flbuff
End Function
'写入到文件
Public Function SaveFile(name As String) As Boolean
    Dim fp As Integer
    If Len(name) = 0 Then name = filename
    If Len(name) = 0 Then Exit Function
   
    fp = FreeFile
    Open name For Output As fp
        Print #fp, "<?xml version=""1.0"" encoding=""gb2312"" ?>"
        mywrite 0, fp
    Close fp
End Function
' 一个递归函数，用来添加字符
Public Function read(ByRef buff As String) As cls_Tree
On Error Resume Next
Dim c1 As String
Dim ntree As cls_Tree
    buff = Trim(buff)
    If Len(buff) = 0 Then Exit Function
    If Mid(buff, 1, 1) <> "<" Then
        Exit Function     '违犯规则
    End If
    'While Mid(buff, 1, 2) <> "</"
    If Mid(buff, 1, 2) = "</" Then Exit Function
    c1 = Mid(buff, 2, InStr(1, buff, ">") - 2)
    buff = Mid(buff, Len(c1) + 3, Len(buff))
    If c1 = "" Then Exit Function
    If Mid(c1, 1, 1) = "/" Then Exit Function
    If InStr(1, c1, "=") = 0 Then      '是目录
        Set ntree = AddYezi(XmlToStr(c1), "", "")
        While StrComp(Mid(buff, 1, 2), "</", vbTextCompare) <> 0 And Len(buff) <> 0 '0是完全相同，1是部分相同，-1是不相同
            ntree.read buff
        Wend
        If Len(buff) = 0 Then Exit Function
        buff = Mid(buff, InStr(1, buff, ">") + 1, Len(buff))
    Else
        Dim str1() As String
        str1 = Split(c1, """")
        Call AddYezi("", XmlToStr(str1(1)), XmlToStr(str1(3)))
    End If
End Function

Public Function mywrite(ceng As Integer, fp As Integer)
    ''on error Resume Next
    If fp = 0 Then Exit Function
    '先把目录写进去
    Dim cnt1 As Integer
    Dim cnt2 As Integer
    If isnothing(Ctree) = False Then
        For cnt2 = 0 To UBound(Ctree)
            Print #fp, Space(ceng * 4) & "<" & StrToXml(Ctree(cnt2).name) & ">"
            Ctree(cnt2).mywrite ceng + 1, fp
            Print #fp, Space(ceng * 4) & "</" & StrToXml(Ctree(cnt2).name) & ">"
        Next
    End If
    If isnothing(Cyezi) = False Then
        For cnt2 = 0 To UBound(Cyezi)
            '在这里把不能写入的符号转成XML格式，如＜
            Print #fp, Space(ceng * 4) & "<" & StrToXml(Cyezi(cnt2).name) & ">" & StrToXml(Cyezi(cnt2).val) & "</" & StrToXml(Cyezi(cnt2).name) & ">"
        Next
    End If
End Function
Public Function StrToXml(ByVal str As String) As String
    str = Replace(str, "&", "&amp;")
    str = Replace(str, ">", "&gt;")
    str = Replace(str, """", "&quot;")
    str = Replace(str, "<", "&lt;")
    StrToXml = str
End Function
Public Function XmlToStr(ByVal xml As String) As String
    xml = Replace(xml, "&gt;", ">", 1)
    xml = Replace(xml, "&quot;", """", 1)
    xml = Replace(xml, "&lt;", "<", 1)
    xml = Replace(xml, "&amp;", "&", 1)
    XmlToStr = xml
End Function