C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

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

このクラスのメソッドは以前、何処かのサイトにあったものを流用したので、
細かな事はわかっていませんw

過去に作った、BodyのTreeをTXT,CSV,XMLで出力するマクロを流用したので、
XmlProductMainモジュール以外は、少し変更した程度で出来ました。

マクロの使用方法は、Productをアクティブな状態でマクロを実行するだけです。
一番上のProductファイルと同じフォルダ内に "Productファイル名.xml" が出来上がります。