ProductTreeをXMLﾌｫｰﾏｯﾄでｴｸｽﾎﾟｰﾄする

先日ご紹介した "スタック・オーバーフロー" のｻｲﾄに
"ProductのTreeをXMLﾌｫｰﾏｯﾄで出力したいのだが" みたいな
質問がありました。
vbscript - generate xml file from Catia treeview - Stack Overflow

で、VBAで作ってみました。
出来上がりはこんな感じ。(左からCATIA,TXT,XML)
f:id:kandennti:20150821162214p:plain

かなりｲﾏｲﾁです。　もっと色々な情報も出力できるのですが
どんな感じのものが需要としてあるものか？　がわかっていません。
(ﾘｸｴｽﾄがあれば修正します)

ｿｰｽｺｰﾄﾞです。
CATMainを持つXmlProductMainﾓｼﾞｭｰﾙです。

'VBA CATProductをXMLでｴｸｽﾎﾟｰﾄ
'XmlProductMainﾓｼﾞｭｰﾙ
Dim Tree As XmlProductTree

Sub CATMain()
    'ｵｰﾌﾟﾝﾁｪｯｸ
    Dim ProductDoc As ProductDocument
    If Not TryProductDoc(CATIA.ActiveDocument, ProductDoc) Then
        Call MsgBox("CATProductをｱｸﾃｨﾌﾞ又は開いて下さい")
        End
    End If
    
    'Product取得
    Set Tree = New XmlProductTree
    Call GetProduct(ProductDoc.Product, 0)
    
    'ﾌｧｲﾙ名作成
    Dim ExFileName As String
    ExFileName = createFileName(ProductDoc.Path, ProductDoc.Name)
    
    'ｴｸｽﾎﾟｰﾄ
    Dim XPFO As New XmlProductFileOpe
    Call XPFO.ExpXml(ProductDoc.Path, ProductDoc.Name, Tree.GetTreeList, ExFileName)
    Call MsgBox("「" + ExFileName + "」を作成しました。")
    Set Tree = Nothing
    'Stop
End Sub

'Product取得
Private Sub GetProduct(Pro As Product, ParentId As Integer)
    Dim Node As New XmlProductNode
    Call Node.Constructor(Pro, ParentId)
    
    Dim Id As Integer
    Id = Tree.Add(Node)
    
    Dim P As Product
    For Each P In Pro.Products
        Call GetProduct(P, Id)
    Next
End Sub

'ProductDocumentのチェック
Private Function TryProductDoc(ByRef Doc As Document, ByRef ReturnDoc As ProductDocument) As Boolean
    On Error Resume Next
        Set ReturnDoc = Doc
        If Err.Number = 0 Then
            TryProductDoc = True
        Else
            TryProductDoc = False
        End If
    On Error GoTo 0
End Function

'重複しないファイル名を取得
Private Function createFileName(sPath As String, sBaseName As String) As String
    Dim FSO As Object 'As FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FileExists(sPath + "\" + sBaseName + ".xml") Then
        createFileName = sBaseName + ".xml"
        Set FSO = Nothing
        Exit Function
    End If
    
    Dim I As Integer
    I = 1
    Do
        If Not FSO.FileExists(sPath + "\" + sBaseName + CStr(I) + ".xml") Then
            createFileName = sBaseName + CStr(I) + ".xml"
            Set FSO = Nothing
            Exit Function
        End If
        I = I + 1
    Loop
End Function

createFileNameﾒｿｯﾄﾞは以前は再帰で行っていたのですが、再帰も大げさな
気がしたのでﾙｰﾌﾟにしましたが、結構がっかりなｺｰﾄﾞです。

続いて、Treeのﾉｰﾄﾞを管理するXmlProductNodeｸﾗｽです。

'VBA CATProductをXMLでｴｸｽﾎﾟｰﾄ
'XmlProductNodeｸﾗｽ
Option Explicit
Public Id As Integer '自身のID
Public ChildrenIds As Collection '子のID
Private m_parentId As Integer '親のID
Private m_name As String '名前
Private m_partNumber As String
Private m_path As String

'引数付きコンストラクタの代わり
Sub Constructor(Pro As Product, ParentId As Integer)
    m_name = Pro.Name
    m_parentId = ParentId
    m_partNumber = Pro.PartNumber
    Set ChildrenIds = New Collection
End Sub

Private Sub Class_Terminate()
    Set ChildrenIds = Nothing
End Sub

Function getName() As String
    getName = m_name
End Function

Function getPartNumber() As String
    getPartNumber = m_partNumber
End Function

Function getParentId() As Integer
    getParentId = m_parentId
End Function

続いて、Treeを管理するXmlProductTreeｸﾗｽです。

'VBA CATProductをXMLでｴｸｽﾎﾟｰﾄ
'XmlProductTreeｸﾗｽ
Option Explicit
Private m_Tree As Collection

Private Sub Class_Initialize()
    Set m_Tree = New Collection
End Sub

Private Sub Class_Terminate()
    Dim Node As XmlProductNode
    For Each Node In m_Tree
        Set Node = Nothing
    Next
    Set m_Tree = Nothing
End Sub

'nodeの追加
Function Add(Node As XmlProductNode) As Integer
    Dim Id As Integer
    
    Id = m_Tree.Count + 1
    Node.Id = Id '自身のID登録
    Call m_Tree.Add(Node) '追加
    Add = Id
    
    '最初のBodyに親は無しとする
    If Id = 1 Then Exit Function
    
    '親のChildrenIdに自身のIDを登録
    Call m_Tree.Item(Node.getParentId).ChildrenIds.Add(Id)
End Function

'Treeの出力
Function GetTreeList() As Collection
    Set GetTreeList = m_Tree
End Function

最後に、XMLﾌｫｰﾏｯﾄで出力させるXmlProductFileOpeｸﾗｽです。

'VBA CATProductをXMLでｴｸｽﾎﾟｰﾄ
'XmlProductFileOpeｸﾗｽ
Option Explicit

Sub ExpXml(ProductPath As String, ProductName As String, CatTree As Collection, ExpName As String)
    Dim xmlDoc As Object 'MSXML2.DOMDocument
    Dim xmlNode As Object 'MSXML2.IXMLDOMNode
    
    'XMLDOMDocument作成
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
     
    'XML宣言
    Set xmlNode = xmlDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""Shift_JIS""")
    xmlDoc.appendChild xmlNode
    
    Set xmlNode = xmlDoc
    Set xmlNode = CreateElementNode(xmlNode, "Top", "")
    Call CreateAttribute(xmlNode, "filepath", ProductPath + "\" + ProductName)
    Call CreateElementNode(xmlNode, "day_time", CStr(Now))
    
    Call GetXmlChildren(CatTree.Item(1), xmlNode, CatTree)
    xmlDoc.Save ProductPath + "\" + ExpName
    Set xmlDoc = Nothing
End Sub

'XML子-再帰
Private Sub GetXmlChildren(Node As XmlProductNode, ParentNode As Object, CatTree As Collection)
    Dim nextNode As Object ' MSXML2.IXMLDOMNode
    Dim Child As Variant
    
    Set nextNode = CreateElementNode(ParentNode, "Product", "")
    Call CreateAttribute(nextNode, "Part_Number", Node.getPartNumber)
    Call CreateAttribute(nextNode, "Instance_name", Node.getName)

    If Node.ChildrenIds.Count > 0 Then
        For Each Child In Node.ChildrenIds
            Call GetXmlChildren(CatTree.Item(Child), nextNode, CatTree)
        Next
    End If
End Sub

'XMLDOMNodeを作成
Private Function CreateElementNode(ParentNode, tagName, Text)
    Dim objNode As Object 'XMLのNodeオブジェクト
    
    Set objNode = _
      ParentNode.selectSingleNode("/").createElement(tagName)
    If Text <> "" Then objNode.Text = Text
    ParentNode.appendChild objNode
    
    Set CreateElementNode = objNode
End Function
 
'XMLDOMAttributeを作成
Private Function CreateAttribute(targetNode, attributeName, Text)
    Dim objAttr As Object 'XMLのAttributeオブジェクト
    
    Set objAttr = _
      targetNode.selectSingleNode("/").CreateAttribute(attributeName)
    objAttr.Text = Text
    targetNode.Attributes.setNamedItem objAttr
    
    Set CreateAttribute = objAttr
End Function