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

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

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

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

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

マクロの機能

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

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

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

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

サンプルコード

マクロのコードは下記のとおりです。
マクロを実行してまず始めに注釈セット内にある「ビュー」を選択します。
ここで選択したビュー上にすべてのテキストが作成されます。
※選択するビューは「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

コード解説

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

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

 'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義
    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

次にユーザーが選択した注釈セット内のビュー(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

次にユーザーが選択した注釈セットを定義します。
既に注釈セットがある場合はそれを、存在しない場合は新たに注釈セットを作成し「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をアクティブにします。アクティブビューの切り替えはAnnotationSetオブジェクトの「ActiveViewプロパティ」の中身を変更すれればOKです。

　
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)

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

次に作成した点をひとまとめにするための形状セットを作成します。
形状セットの名前は「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

座標を取得し、点を作成という処理を繰り返すためループ文を使います。

ここではテキストの作成についてのコード解説をしていきます。
(点の作成については「Excelの表から座標を取得し点を作成」のコード解説を参照下さい)

テキストに作成は「AnnotationFactory」の「CreateEvoluateTextメソッド」を使います。

ユーザーサーフェスには、テキスト作成時に必要なオブジェクトをRefernceとして入力します。
今回のサンプルマクロの場合、このオブジェクトは「点」にあたります。

X座標, Y座標, Z座標にはテキストの座標を入力します。ただ、ここで入力する座標の絶対座標はアクティブ状態のビューによって変化するので注意しましょう。

矢印線の有無には「True」「False」のいずれかを入力します。
「True」の場合は矢印線(Leader)が作成されます。

テキストはビューによって作成方法が少しずつ違ってくるので、サンプルマクロでは「XY」「YZ」「ZX」と条件分けをして作成しています。この部分は自身の環境に合わせて書き換えて下さい。

まとめ

今回はExcelの表から取得した値で点とテキストを作成するマクロについての内容でした。

基本的には「Excelの表から座標を取得し点を作成」で紹介した内容に「AnnotationFactory」の「CreateEvoluateTextメソッド」を使ってテキスト追加の処理をプラスしただけです。

注釈が絡むマクロは少し複雑なのでいろいろ試して徐々に理解していって下さい。

サンプルマクロ集に戻る
目次へ戻る

 CATIAマクロを本気で勉強するなら

Vb Scripting for Catia V5: How to Program Catia Macros

created by Rinker

• Kindle
• Amazon
• 楽天市場
• Yahooショッピング

CATIA V5: Macro Programming with Visual Basic Script

created by Rinker

McGraw-Hill Education

• Kindle
• Amazon
• 楽天市場
• Yahooショッピング