Excelの表から取得した値で点とテキストを作成するマクロ｜CATIAマクロの作成方法

今回はマクロ案募集で頂いた内容です。
頂いた内容は以下のとおりです。

ワークベンチ:
パートデザイン

マクロ案:
予め準備した座標値(X,Y,Z)と文字を基に３D上に点を作成し、合わせて文字も同じ位置に配置する

今回は「Excelの表から座標を取得し点を作成」で紹介したコードを少し修正してサンプルマクロを作成しました。下記のようなExcelファイルを読み込ませ「点」と「テキスト」を作成します。

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

マクロの機能

今回作成したのはExcelの表から点とテキストを作成するマクロです。

Excelに書かれている「X座標」「Y座標」「Z座標」という文字を読み取って取得する列を指定しているわけではなく、「B列」「C列」「D列」の値を取得するという処理を行っています。

そのためExcelファイルの方で1行ずれて記入した場合、うまくマクロが作動しません。
Excelファイルが上図と同じテンプレであること前提のマクロとなっているため注意して下さい。
(※B列にX座標,C列にY座標,D列にZ座標それぞれの座標値は2行目以降に記入されているものに限る)

マクロの機能をまとめると以下のとおりです。

マクロの機能まとめ・選択したExcelの表から座標値を取得し、CATIAで同座標位置に点を作成
・ExcelのE列に書かれている文字列をもとに、選択したビュー上にテキストを作成
→ ※事前にビューを作成しておく必要あり
・作成する点の名前はExcelのA列に書かれている文字列
・作成した点はすべて新規作成される形状セットにまとまる
・形状セットはツリー第1階層に作成される
・新規形状セットの名前は選択したExcelのファイル名

サンプルコード

マクロのコードは下記のとおりです。
マクロを実行してまず始めに注釈セット内にある「ビュー」を選択します。
ここで選択したビュー上にすべてのテキストが作成されます。
※選択するビューは「XY平面」「YZ平面」「ZX平面」を基準としたビューを前提としています。
　ビューのサポートや角度等でうまく実行できない場合があるので注意して下さい。

ビュー選択後は「ファイルを開く」ウィンドウが立ち上がります。
ここで開いたExcelファイルの表を読み取りCATIA内で点を作成します。

Option Explicit
Sub CATMain()

 'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義
    If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
        MsgBox "CATPartに切り替えてからマクロを実行してください。"
        Exit Sub
    End If
    
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    Dim pt As Part
    Set pt = doc.Part
    
 'Selection定義
    Dim sel 'As Selection
    Set sel = doc.Selection
    sel.Clear

 'TPSView定義
    Dim filter():       filter = Array("TPSView")
    Dim msg As String:  msg = "基準とするビューを選択して下さい。"
    
    Dim status As String
    status = sel.SelectElement2(filter, msg, False)
    If status <> "Normal" Then
        MsgBox "キャンセルしました。"
        End
    End If
    
    Dim tps As TPSView
    Set tps = sel.Item(1).Value
 
 '注釈ｾｯﾄ定義
    Dim annSet As AnnotationSet
    If pt.AnnotationSets.Count = 0 Then
        Set annSet = pt.AnnotationSets.Add("")
    Else
        Set annSet = pt.AnnotationSets.Item(1)
    End If
    
 '選択されたTPSViewをｱｸﾃｨﾌﾞに
    Dim i As Integer:       i = 1
    Dim tpsTmp As TPSView
    Do
        Set tpsTmp = annSet.TPSViews.Item(i)
        
        If tps.Name = tpsTmp.Name Then
            annSet.ActiveView = annSet.TPSViews.Item(i)
            Exit Do
        End If
        i = i + 1
    Loop
    
 'AnnotationFactory定義
    Dim annf As AnnotationFactory
    Set annf = annSet.AnnotationFactory
    
 'Excel定義
    Dim appExcel As Excel.Application
    Set appExcel = CreateObject("Excel.Application")
    
    Dim OpenFileName As String
    OpenFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xlsx")
    If OpenFileName <> "False" Then
        Dim wb As Workbook
        Set wb = Workbooks.Open(OpenFileName)
    Else
        MsgBox "キャンセルされました"
        Exit Sub
    End If
    
 'ﾜｰｸｼｰﾄ定義
    Dim ws As Worksheet
    Set ws = wb.Sheets(1)
    
 '形状ｾｯﾄ作成
    Dim hb As HybridBody
    Set hb = pt.HybridBodies.Add
    hb.Name = wb.Name
    
 'ﾜｰｸｼｰﾄ最下行取得
    Dim MaxRow As Integer
    MaxRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To MaxRow
    
     'Excelから値を取得
        Dim PointName As String:    PointName = ws.Cells(i, 1).Value
        Dim Xvalue As Single:       Xvalue = ws.Cells(i, 2).Value
        Dim Yvalue As Single:       Yvalue = ws.Cells(i, 3).Value
        Dim Zvalue As Single:       Zvalue = ws.Cells(i, 4).Value
        Dim txt As String:          txt = ws.Cells(i, 5).Value
        
     '点作成
        Dim p As HybridShapePointCoord
        Set p = pt.HybridShapeFactory.AddNewPointCoord(Xvalue, Yvalue, Zvalue)
        hb.AppendHybridShape p
        
        p.Name = PointName
        pt.Update
     
     'UserSurface定義
        Dim pRef As Reference
        Set pRef = pt.CreateReferenceFromObject(p)
        
        Dim uSurf As UserSurface
        Set uSurf = pt.UserSurfaces.Generate(pRef)

     'ｱﾉﾃｰｼｮﾝ作成
        Dim ann As Annotation
        
        If tps.Name = "XYﾋﾞｭｰ" Then
            Set ann = annf.CreateEvoluateText(uSurf, Xvalue, Yvalue, 0, False)
        ElseIf tps.Name = "YZﾋﾞｭｰ" Then
            Set ann = annf.CreateEvoluateText(uSurf, -Yvalue, Zvalue, 0, False)
        ElseIf tps.Name = "ZXﾋﾞｭｰ" Then
            Set ann = annf.CreateEvoluateText(uSurf, Xvalue, Zvalue, 0, False)
        End If
        
        ann.Text.Text = txt
        ann.Name = txt
        
    Next i
    
    pt.Update
    wb.Close False
    
    MsgBox "完了しました。" & vbLf & tps.Name & "ビューを基準にテキストを配置しました。"

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

Option Explicit

Sub CATMain()

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

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

MsgBox "CATPartに切り替えてからマクロを実行してください。"

Exit Sub

End If

Dim doc As PartDocument

Set doc = CATIA.ActiveDocument

Dim pt As Part

Set pt = doc.Part

'Selection定義

Dim sel 'As Selection

Set sel = doc.Selection

sel.Clear

'TPSView定義

Dim filter(): filter = Array("TPSView")

Dim msg As String: msg = "基準とするビューを選択して下さい。"

Dim status As String

status = sel.SelectElement2(filter, msg, False)

If status <> "Normal" Then

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

End

End If

Dim tps As TPSView

Set tps = sel.Item(1).Value

'注釈ｾｯﾄ定義

Dim annSet As AnnotationSet

If pt.AnnotationSets.Count = 0 Then

Set annSet = pt.AnnotationSets.Add("")

Else

Set annSet = pt.AnnotationSets.Item(1)

End If

'選択されたTPSViewをｱｸﾃｨﾌﾞに

Dim i As Integer: i = 1

Dim tpsTmp As TPSView

Set tpsTmp = annSet.TPSViews.Item(i)

If tps.Name = tpsTmp.Name Then

annSet.ActiveView = annSet.TPSViews.Item(i)

Exit Do

End If

i = i + 1

Loop

'AnnotationFactory定義

Dim annf As AnnotationFactory

Set annf = annSet.AnnotationFactory

'Excel定義

Dim appExcel As Excel.Application

Set appExcel = CreateObject("Excel.Application")

Dim OpenFileName As String

OpenFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xlsx")

If OpenFileName <> "False" Then

Dim wb As Workbook

Set wb = Workbooks.Open(OpenFileName)

Else

MsgBox "キャンセルされました"

Exit Sub

End If

'ﾜｰｸｼｰﾄ定義

Dim ws As Worksheet

Set ws = wb.Sheets(1)

'形状ｾｯﾄ作成

Dim hb As HybridBody

Set hb = pt.HybridBodies.Add

hb.Name = wb.Name

'ﾜｰｸｼｰﾄ最下行取得

Dim MaxRow As Integer

MaxRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To MaxRow

'Excelから値を取得

Dim PointName As String: PointName = ws.Cells(i, 1).Value

Dim Xvalue As Single: Xvalue = ws.Cells(i, 2).Value

Dim Yvalue As Single: Yvalue = ws.Cells(i, 3).Value

Dim Zvalue As Single: Zvalue = ws.Cells(i, 4).Value

Dim txt As String: txt = ws.Cells(i, 5).Value

'点作成

Dim p As HybridShapePointCoord

Set p = pt.HybridShapeFactory.AddNewPointCoord(Xvalue, Yvalue, Zvalue)

hb.AppendHybridShape p

p.Name = PointName

pt.Update

'UserSurface定義

Dim pRef As Reference

Set pRef = pt.CreateReferenceFromObject(p)

Dim uSurf As UserSurface

Set uSurf = pt.UserSurfaces.Generate(pRef)

'ｱﾉﾃｰｼｮﾝ作成

Dim ann As Annotation

If tps.Name = "XYﾋﾞｭｰ" Then

Set ann = annf.CreateEvoluateText(uSurf, Xvalue, Yvalue, 0, False)

ElseIf tps.Name = "YZﾋﾞｭｰ" Then

Set ann = annf.CreateEvoluateText(uSurf, -Yvalue, Zvalue, 0, False)

ElseIf tps.Name = "ZXﾋﾞｭｰ" Then

Set ann = annf.CreateEvoluateText(uSurf, Xvalue, Zvalue, 0, False)

End If

ann.Text.Text = txt

ann.Name = txt

Next i

pt.Update

wb.Close False

MsgBox "完了しました。" & vbLf & tps.Name & "ビューを基準にテキストを配置しました。"

End Sub

コード解説

本マクロのコードを上から順に部分ごとにわけて解説していきます。
※コード内でもコメントで解説をしているのでそちらも参照ください。
　

アクティブドキュメントの定義

 'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義
    If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
        MsgBox "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 "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も変数「pt」に代入します。
　

TPSView定義

 'Selection定義
    Dim sel 'As Selection
    Set sel = doc.Selection
    sel.Clear

 'TPSView定義
    Dim filter():       filter = Array("TPSView")
    Dim msg As String:  msg = "基準とするビューを選択して下さい。"
    
    Dim status As String
    status = sel.SelectElement2(filter, msg, False)
    If status <> "Normal" Then
        MsgBox "キャンセルしました。"
        End
    End If
    
    Dim tps As TPSView
    Set tps = sel.Item(1).Value

'Selection定義

Dim sel 'As Selection

Set sel = doc.Selection

sel.Clear

'TPSView定義

Dim filter(): filter = Array("TPSView")

Dim msg As String: msg = "基準とするビューを選択して下さい。"

Dim status As String

status = sel.SelectElement2(filter, msg, False)

If status <> "Normal" Then

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

End

End If

Dim tps As TPSView

Set tps = sel.Item(1).Value

次にユーザーが選択した注釈セット内のビュー(TPSViewオブジェクト)を定義します。
「Selectionオブジェクト」の「SelectElement2メソッド」を使ってTPSViewを取得します。

基本的には定型文なので詳しくは上記リンクページを確認して下さい。SelectElement2メソッドを使うには「As Selection」と型を指定していると使えないので注意しましょう。　
　

注釈セット定義

'注釈ｾｯﾄ定義
    Dim annSet As AnnotationSet
    If pt.AnnotationSets.Count = 0 Then
        Set annSet = pt.AnnotationSets.Add("")
    Else
        Set annSet = pt.AnnotationSets.Item(1)
    End If

'注釈ｾｯﾄ定義

Dim annSet As AnnotationSet

If pt.AnnotationSets.Count = 0 Then

Set annSet = pt.AnnotationSets.Add("")

Else

Set annSet = pt.AnnotationSets.Item(1)

End If

次にユーザーが選択した注釈セットを定義します。
既に注釈セットがある場合はそれを、存在しない場合は新たに注釈セットを作成し「annSet」として定義します。　
　

選択されたTPSViewをｱｸﾃｨﾌﾞに

 '選択されたTPSViewをｱｸﾃｨﾌﾞに
    Dim i As Integer:       i = 1
    Dim tpsTmp As TPSView
    Do
        Set tpsTmp = annSet.TPSViews.Item(i)
        
        If tps.Name = tpsTmp.Name Then
            annSet.ActiveView = annSet.TPSViews.Item(i)
            Exit Do
        End If
        i = i + 1
    Loop

'選択されたTPSViewをｱｸﾃｨﾌﾞに

Dim i As Integer: i = 1

Dim tpsTmp As TPSView

Set tpsTmp = annSet.TPSViews.Item(i)

If tps.Name = tpsTmp.Name Then

annSet.ActiveView = annSet.TPSViews.Item(i)

Exit Do

End If

i = i + 1

Loop

テキストはそのときアクティブ状態のビュー上に作成されるため、選択されたTPSViewをアクティブにします。アクティブビューの切り替えはAnnotationSetオブジェクトの「ActiveViewプロパティ」の中身を変更すれればOKです。

TPSViewをアクティブに

AnnotationSetオブジェクト.ActiveView = TPSViewオブジェクト　

　
AnnotationFactory定義

 'AnnotationFactory定義
    Dim annf As AnnotationFactory
    Set annf = annSet.AnnotationFactory

'AnnotationFactory定義

Dim annf As AnnotationFactory

Set annf = annSet.AnnotationFactory

次に「AnnotationFactory」を定義します。
これは「Factory」「HybridShapeFactory」と同じ部類のオブジェクトで、アノテーションやテキストを作成するために必要なオブジェクトです。
　

Excelの定義

 'Excel定義
    Dim appExcel As Excel.Application
    Set appExcel = CreateObject("Excel.Application")
    
    Dim OpenFileName As String
    OpenFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xlsx")
    If OpenFileName <> "False" Then
        Dim wb As Workbook
        Set wb = Workbooks.Open(OpenFileName)
    Else
        MsgBox "キャンセルされました"
        Exit Sub
    End If
    
 'ﾜｰｸｼｰﾄ定義
    Dim ws As Worksheet
    Set ws = wb.Sheets(1)

'Excel定義

Dim appExcel As Excel.Application

Set appExcel = CreateObject("Excel.Application")

Dim OpenFileName As String

OpenFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xlsx")

If OpenFileName <> "False" Then

Dim wb As Workbook

Set wb = Workbooks.Open(OpenFileName)

Else

MsgBox "キャンセルされました"

Exit Sub

End If

'ﾜｰｸｼｰﾄ定義

Dim ws As Worksheet

Set ws = wb.Sheets(1)

CATIAマクロ上でExcel VBAを使用できるようにExcelを定義します。
上記コードでExcelが定義できない場合は、参照設定がされていない可能性があります。
詳しくは下記ページの「Excelマクロのライブラリを読み込む」の項を一読ください。

CATIAマクロでExcelを操作する方法｜CATIAマクロの作成方法

今回はCATIAマクロでExcelを操作する方法を解説していきます。 Excelと連携することで仕事内容によって ...

https://liclog.net/export-excel-macro-vba-catia-v5/

　
Excelを定義後は「GetOpenFilenameメソッド」を使って、
出力元となるExcelファイル(ブック)をユーザーに選択させ、変数「wb」として代入します。

変数「wb」を定義したら、wbの1つ目のシートを変数「ws」に代入します。
このWSに書かれている座標値をもとに点が作成されます。

形状セットの作成

 '形状ｾｯﾄ作成
    Dim hb As HybridBody
    Set hb = pt.HybridBodies.Add
    hb.Name = wb.Name

'形状ｾｯﾄ作成

Dim hb As HybridBody

Set hb = pt.HybridBodies.Add

hb.Name = wb.Name

次に作成した点をひとまとめにするための形状セットを作成します。
形状セットの名前は「wb.Name」、つまり選択したExcelファイルと同じ名前にします。

座標の取得/点とテキストの作成

 'ﾜｰｸｼｰﾄ最下行取得
    Dim MaxRow As Integer
    MaxRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To MaxRow
    
     'Excelから値を取得
        Dim PointName As String:    PointName = ws.Cells(i, 1).Value
        Dim Xvalue As Single:       Xvalue = ws.Cells(i, 2).Value
        Dim Yvalue As Single:       Yvalue = ws.Cells(i, 3).Value
        Dim Zvalue As Single:       Zvalue = ws.Cells(i, 4).Value
        Dim txt As String:          txt = ws.Cells(i, 5).Value
        
     '点作成
        Dim p As HybridShapePointCoord
        Set p = pt.HybridShapeFactory.AddNewPointCoord(Xvalue, Yvalue, Zvalue)
        hb.AppendHybridShape p
        
        p.Name = PointName
        pt.Update
     
     'UserSurface定義
        Dim pRef As Reference
        Set pRef = pt.CreateReferenceFromObject(p)
        
        Dim uSurf As UserSurface
        Set uSurf = pt.UserSurfaces.Generate(pRef)

     'ｱﾉﾃｰｼｮﾝ作成
        Dim ann As Annotation
        
        If tps.Name = "XYﾋﾞｭｰ" Then
            Set ann = annf.CreateEvoluateText(uSurf, Xvalue, Yvalue, 0, False)
        ElseIf tps.Name = "YZﾋﾞｭｰ" Then
            Set ann = annf.CreateEvoluateText(uSurf, -Yvalue, Zvalue, 0, False)
        ElseIf tps.Name = "ZXﾋﾞｭｰ" Then
            Set ann = annf.CreateEvoluateText(uSurf, Xvalue, Zvalue, 0, False)
        End If
        
        ann.Text.Text = txt
        ann.Name = txt
        
    Next i