ボリューム化したサーフェスの体積を測定しExcelに出力するマクロ｜CATIAマクロの作成方法

今回は「お問い合わせ」より頂いた内容です。
送って頂いた内容は以下のようなマクロです。

お問い合わせ内容:
1つのcatpartの中にある
複数の閉じた形状（サーフェス）の
体積を取得し、エクセルに書き出したいです。

使用目的としては、
エクセル上で取得した体積に、比重をかけて複数の部品の質量を求めたい。
（複数管理をしたいため）→エクセルで保存したいです。

1. マクロの機能
2. サンプルコード
3. コード解説
4. まとめ

マクロの機能

今回作成したマクロは
『ボリューム化したサーフェスの体積を測定しExcelに出力するマクロ』です。

具体的な機能は以下のとおりです。

マクロの機能まとめ・選択した形状セット内のサーフェスをボリューム化し、その体積をExcelに出力する
　※形状セット内は体積を測定するサーフェスのみが入っていることが前提条件
　　ボリューム化＝クローズサーフェス
・ExcelにはA列にサーフェス名、B列に体積(mm^3)を出力する
・出力したExcelは手動で保存する必要あり

クローズサーフェスが作成できない場合はエラーが発生するので、インプットする形状セット内のサーフェスの形状には注意して下さい。

また「On Error Resume Next」でエラーを無視させることでマクロとしての機能をゴリ押しで使うこともでるので、マクロが動きさえすればいいという場合はサンプルコードの初めに「On Error Resume Next」と書いて使って下さい。
(この場合、エラーが出るサーフェスの体積は「0」として出力されます)

サンプルコード

マクロのサンプルコードは以下のとおりです。
事前にExcelライブラリの設定をしておかないとExcel定義用のコードでエラーが発生するので、まだ設定されていない場合は「CATIAマクロでExcelを操作する方法」ページを参照して設定しておいてください。

Option Explicit
Sub CATMain()

 'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義
    If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
       MsgBox "このマクロはPartDocument専用です。" & vbLf & _
              "CATPartに切り替えて実行してください。"
       Exit Sub
    End If

    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    Dim pt As Part
    Set pt = doc.Part

 'ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得
    Dim sel 'As Selection
    Set sel = doc.Selection
    sel.Clear
    
    Dim filter
    Dim res As String
    Dim hb As HybridBody
    
    filter = Array("HybridBody")
    res = sel.SelectElement2(filter, "", False)
    If res <> "Normal" Then
        MsgBox "キャンセルしました。"
        Exit Sub
    End If
    Set hb = sel.Item(1).Value
    
 '体積/名称格納用の配列を用意
    Dim vols() As Double
    Dim names() As String
    ReDim vols(hb.HybridShapes.Count)
    ReDim names(hb.HybridShapes.Count)
    
 '体積を測定し配列に格納
    Dim sf As ShapeFactory
    Dim spa As Workbench
    Dim measure As Measurable
    Dim hs
    Dim vol
    Dim ref_hs As Reference
    Dim ref_vol As Reference
    Dim i As Long
    
    Set sf = pt.ShapeFactory
    Set spa = doc.GetWorkbench("SPAWorkbench")
    
    i = 1
    For Each hs In hb.HybridShapes
    
     '名称格納(Excel出力用)
        names(i) = hs.Name
    
     'ｸﾛｰｽﾞｻｰﾌｪｽ作成
        Set ref_hs = pt.CreateReferenceFromObject(hs)
        Set vol = sf.AddNewVolumeCloseSurface(ref_hs)
        pt.UpdateObject vol
    
     'ｸﾛｰｽﾞｻｰﾌｪｽの体積(mm^3)を測定して配列に格納
        Set ref_vol = pt.CreateReferenceFromObject(vol)
        Set measure = spa.GetMeasurable(ref_vol)
        vols(i) = measure.Volume * 1000000000
        
     '作成したｸﾛｰｽﾞｻｰﾌｪｽを削除
        sel.Clear
        sel.Add vol
        sel.Delete
        
        i = i + 1
    Next hs

 'Excel定義
    Dim Excel As Excel.Application
    Set Excel = CreateObject("Excel.Application")
    
    Dim wb As Workbook
    Set wb = Excel.Workbooks.Add

    Dim ws As Worksheet
    Set ws = wb.Sheets(1)
    
 'Excel出力
    For i = 1 To UBound(vols)
        ws.Cells(i, 1).Value = names(i)
        ws.Cells(i, 2).Value = vols(i)
    Next i

    Excel.Visible = True

End Sub

Option Explicit

Sub CATMain()

'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義

If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then

MsgBox "このマクロはPartDocument専用です。" & vbLf & _

"CATPartに切り替えて実行してください。"

Exit Sub

End If

Dim doc As PartDocument

Set doc = CATIA.ActiveDocument

Dim pt As Part

Set pt = doc.Part

'ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得

Dim sel 'As Selection

Set sel = doc.Selection

sel.Clear

Dim filter

Dim res As String

Dim hb As HybridBody

filter = Array("HybridBody")

res = sel.SelectElement2(filter, "", False)

If res <> "Normal" Then

MsgBox "キャンセルしました。"

Exit Sub

End If

Set hb = sel.Item(1).Value

'体積/名称格納用の配列を用意

Dim vols() As Double

Dim names() As String

ReDim vols(hb.HybridShapes.Count)

ReDim names(hb.HybridShapes.Count)

'体積を測定し配列に格納

Dim sf As ShapeFactory

Dim spa As Workbench

Dim measure As Measurable

Dim hs

Dim vol

Dim ref_hs As Reference

Dim ref_vol As Reference

Dim i As Long

Set sf = pt.ShapeFactory

Set spa = doc.GetWorkbench("SPAWorkbench")

i = 1

For Each hs In hb.HybridShapes

'名称格納(Excel出力用)

names(i) = hs.Name

'ｸﾛｰｽﾞｻｰﾌｪｽ作成

Set ref_hs = pt.CreateReferenceFromObject(hs)

Set vol = sf.AddNewVolumeCloseSurface(ref_hs)

pt.UpdateObject vol

'ｸﾛｰｽﾞｻｰﾌｪｽの体積(mm^3)を測定して配列に格納

Set ref_vol = pt.CreateReferenceFromObject(vol)

Set measure = spa.GetMeasurable(ref_vol)

vols(i) = measure.Volume * 1000000000

'作成したｸﾛｰｽﾞｻｰﾌｪｽを削除

sel.Clear

sel.Add vol

sel.Delete

i = i + 1

Next hs

'Excel定義

Dim Excel As Excel.Application

Set Excel = CreateObject("Excel.Application")

Dim wb As Workbook

Set wb = Excel.Workbooks.Add

Dim ws As Worksheet

Set ws = wb.Sheets(1)

'Excel出力

For i = 1 To UBound(vols)

ws.Cells(i, 1).Value = names(i)

ws.Cells(i, 2).Value = vols(i)

Next i

Excel.Visible = True

End Sub

コード解説

ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義

 'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義
    If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
       MsgBox "このマクロはPartDocument専用です。" & vbLf & _
              "CATPartに切り替えて実行してください。"
       Exit Sub
    End If

    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    Dim pt As Part
    Set pt = doc.Part

'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義

If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then

MsgBox "このマクロはPartDocument専用です。" & vbLf & _

"CATPartに切り替えて実行してください。"

Exit Sub

End If

Dim doc As PartDocument

Set doc = CATIA.ActiveDocument

Dim pt As Part

Set pt = doc.Part

まずはじめにアクティブドキュメントの定義をします。

今回のマクロはCATPartでのみ有効なものなので、アクティブドキュメントがCATPart以外の場合はTypeName関数を使った条件分岐でマクロを終了するようにしています。条件分岐の先、つまりはアクティブドキュメントがCATPartの場合は変数「doc」にアクティブドキュメントを代入します。

アクティブドキュメントを定義したら合わせてPartも定義しておきます。
これは以降でReferenceを取得するための「CreateReferenceFromObjectメソッド」、
クローズサーフェスを作成するためのに必要な「ShapeFactoryプロパティ」を使うためです。
　　

ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得

 'ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得
    Dim sel 'As Selection
    Set sel = doc.Selection
    sel.Clear
    
    Dim filter
    Dim res As String
    Dim hb As HybridBody
    
    filter = Array("HybridBody")
    res = sel.SelectElement2(filter, "", False)
    If res <> "Normal" Then
        MsgBox "キャンセルしました。"
        Exit Sub
    End If
    Set hb = sel.Item(1).Value

'ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得

Dim sel 'As Selection

Set sel = doc.Selection

sel.Clear

Dim filter

Dim res As String

Dim hb As HybridBody

filter = Array("HybridBody")

res = sel.SelectElement2(filter, "", False)

If res <> "Normal" Then

MsgBox "キャンセルしました。"

Exit Sub

End If

Set hb = sel.Item(1).Value

つぎにユーザー選択で体積を測定するためのサーフェスが入った形状セットを取得します。
ユーザー選択は「Selectionオブジェクト」の「SelectElement2メソッド」を使用します。
上記コードはほぼ定型文なので処理内容の詳細は上記リンクページを参照下さい。
　

体積/名称格納用の配列を用意

 '体積/名称格納用の配列を用意
    Dim vols() As Double
    Dim names() As String
    ReDim vols(hb.HybridShapes.Count)
    ReDim names(hb.HybridShapes.Count)

'体積/名称格納用の配列を用意

Dim vols() As Double

Dim names() As String

ReDim vols(hb.HybridShapes.Count)

ReDim names(hb.HybridShapes.Count)

つぎに体積とサーフェスの名称を格納するための配列を用意しておきます。
配列の要素数は「hb.HybridShapes.Count」個、つまりは取得した形状セット内にある「HybrisShapeオブジェクト」の数としています。

配列は「0」スタートなので実際は「hb.HybridShapes.Count – 1」とするべきですが、以降でExcelのセルに出力することも考えると「１」スタートの方が扱いやすいです。そのため、配列としては0もある状態ですが、0は無視して1以降の要素を使うような処理としていきます。

配列「vols()」には形状セット内のサーフェスをボリューム化したときの体積が、
配列「names()」には形状セット内のサーフェスの名称がそれぞれ上から順に格納されていきます。
　　

ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得

 '体積を測定し配列に格納
    Dim sf As ShapeFactory
    Dim spa As Workbench
    Dim measure As Measurable
    Dim hs
    Dim vol
    Dim ref_hs As Reference
    Dim ref_vol As Reference
    Dim i As Long
    
    Set sf = pt.ShapeFactory
    Set spa = doc.GetWorkbench("SPAWorkbench")
    
    i = 1
    For Each hs In hb.HybridShapes
    
     '名称格納(Excel出力用)
        names(i) = hs.Name
    
     'ｸﾛｰｽﾞｻｰﾌｪｽ作成
        Set ref_hs = pt.CreateReferenceFromObject(hs)
        Set vol = sf.AddNewVolumeCloseSurface(ref_hs)
        pt.UpdateObject vol
    
     'ｸﾛｰｽﾞｻｰﾌｪｽの体積(mm^3)を測定して配列に格納
        Set ref_vol = pt.CreateReferenceFromObject(vol)
        Set measure = spa.GetMeasurable(ref_vol)
        vols(i) = measure.Volume * 1000000000
        
     '作成したｸﾛｰｽﾞｻｰﾌｪｽを削除
        sel.Clear
        sel.Add vol
        sel.Delete
        
        i = i + 1
    Next hs

'体積を測定し配列に格納

Dim sf As ShapeFactory

Dim spa As Workbench

Dim measure As Measurable

Dim hs

Dim vol

Dim ref_hs As Reference

Dim ref_vol As Reference

Dim i As Long

Set sf = pt.ShapeFactory

Set spa = doc.GetWorkbench("SPAWorkbench")

i = 1

For Each hs In hb.HybridShapes

'名称格納(Excel出力用)

names(i) = hs.Name

'ｸﾛｰｽﾞｻｰﾌｪｽ作成

Set ref_hs = pt.CreateReferenceFromObject(hs)

Set vol = sf.AddNewVolumeCloseSurface(ref_hs)

pt.UpdateObject vol

'ｸﾛｰｽﾞｻｰﾌｪｽの体積(mm^3)を測定して配列に格納

Set ref_vol = pt.CreateReferenceFromObject(vol)

Set measure = spa.GetMeasurable(ref_vol)

vols(i) = measure.Volume * 1000000000

'作成したｸﾛｰｽﾞｻｰﾌｪｽを削除

sel.Clear

sel.Add vol

sel.Delete

i = i + 1

Next hs

つぎに本サンプルマクロのメインとなる「体積の測定」をしていきます。
測定した体積は前項の通り、配列「vols()」に順に格納していきます。これにより、Excelに書き出す際はこの配列の中身を順に書き出していくだけの簡単な処理で済みます。

基本の流れは下記の通りです

① サーフェスの名称を取得 (names()に格納)
② サーフェスを使いクローズサーフェスを作成
③ クローズサーフェスの体積を取得 (vols()に格納)　　　　
④ クローズサーフェスを削除
※ループ文で①～④を形状セット内のサーフェスに対して順に適用させる　

クローズサーフェスの作成は「ShapeFactoryオブジェクト」の「AddNewVolumeCloseSurfaceメソッド」、体積の測定は「Measurableオブジェクト」の「Volumeプロパティ」を使います。

ここで注意する点は「Volumeプロパティ」で取得されるときの体積の単位です。
デフォルトでは「立方メートル(m^3)」となっているので、上記コードでは「立方ミリメートル(mm^3)」に変換させた値を配列「vols()」に格納させています。
適宜、自身の環境に合わせて扱いやすい単位に変換させてください。

Excel定義

 'Excel定義
    Dim Excel As Excel.Application
    Set Excel = CreateObject("Excel.Application")
    
    Dim wb As Workbook
    Set wb = Excel.Workbooks.Add

    Dim ws As Worksheet
    Set ws = wb.Sheets(1)

'Excel定義

Dim Excel As Excel.Application

Set Excel = CreateObject("Excel.Application")

Dim wb As Workbook

Set wb = Excel.Workbooks.Add

Dim ws As Worksheet

Set ws = wb.Sheets(1)

つぎにExcelに出力するために、Excel(アプリケーション)を定義します。
上記コードは定型文のため、詳細は「CATIAマクロでExcelを操作する方法」ページを参照下さい。
※上記コードと合わせてExcelライブラリの設定が必要です
　

ﾕｰｻﾞｰ選択でｻｰﾌｪｽの入った形状ｾｯﾄを取得

 'Excel出力
    For i = 1 To UBound(vols)
        ws.Cells(i, 1).Value = names(i)
        ws.Cells(i, 2).Value = vols(i)
    Next i

    Excel.Visible = True

'Excel出力

For i = 1 To UBound(vols)