CATPartの点座標をExcelに転記して書き換えるマクロ｜CATIAマクロの作成方法

今回はマクロ案より頂いた内容です。
送って頂いた内容は以下のようなマクロです。

ワークベンチ: CATPartとExcel

マクロ案:
CATPart上にある形状セット内の点（例えば点a、点b、点c…etc.）の座標（X,Y,Z）を
Excelで座標入力した値に置き換えれるようなマクロの動きはできないでしょうか？
点の名称はCATPartの形状セット内とExcelはお互いに一致しているものとします。

動きとしては以下のようなイメージをしております。

CATPart形状セット内に元々、点（座標入力によって作られた点）が作られている
↓
（ExcelにCATPart形状セット内の点座標を書き込む）
※この部分はあってもなくてもいいです
↓
Excelにて各点の座標値を入力
↓
Excelで作成した座標値を読み込んでCATPart形状セット内の同じ名称の点の座標値を書き換えていく

本ページのマクロは「Excelに点座標を出力するマクロ」「Excelの値から点座標を書き換えるマクロ」というような2つのマクロではなく、両機能をあわせもった1つのマクロとしています。

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

マクロの機能

今回作成したマクロは『CATPartの点座標をExcelに転記して書き換えるマクロ』です。

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

マクロの機能まとめ・CATPartの点座標をExcelに書き出し、座標値の編集後に点の座標をその値に書き換える
・操作手順は下記を参照

① マクロ実行
② 形状セット選択 (前提条件：座標より作成された点のみが格納されている)　　　
③ Excelが開き、各点の座標が出力される
④ Excel内の座標を任意の値に書き換える
⑤ 書き換え後、UserFormの「Run」をクリック
　 → [Cancel][x]が押された場合はExcelを閉じマクロ終了
⑥ 各点の座標がExcel上で書き換えた座標に更新される

UserFormはExcelの後ろに隠れて表示されているかたちになっているため、わかりづらい場合は任意でUserFormとExcelの表示する位置を書き換えて下さい。

サンプルコード

マクロのサンプルコードは以下のとおりです。
標準モジュールだけでなくUserFormのコードもあるので注意して下さい。

UserFormの名称は「UserForm1」で設定しておいてください。
※CommandButtonはコード上で自動生成するので予め作成しておく必要はありません。

また、本サンプルコードではCATIA VBAでExcelにアクセスするため事前設定が必要です。
詳しくは「CATIAマクロでExcelを操作する方法」ページを参照下さい。

　
標準モジュールコード

Option Explicit
Public cancel_flg As Boolean
Sub CATMain()

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

    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    Dim sel 'As Selection
    Set sel = doc.Selection
    
    Dim pt As Part
    Set pt = doc.Part
    
    Dim hsf As HybridShapeFactory
    Set hsf = pt.HybridShapeFactory
    
 '形状ｾｯﾄ取得
    Dim filter: filter = Array("HybridBody")
    Dim res As String
    res = sel.SelectElement2(filter, "Select Geometrical Set", False)
    If res <> "Normal" Then
        MsgBox "Canceled"
        Exit Sub
    End If
    
    Dim hb As HybridBody
    Set hb = sel.Item(1).Value
    sel.Clear
    
 '点(HybridShapePointCoord)取得
    Dim ps As Collection
    Set ps = New Collection
    
    Dim hs
    For Each hs In hb.HybridShapes
        Dim p As HybridShapePointCoord
        Set p = hs
        ps.Add p
    Next hs
    
 '点の座標を配列に格納
    Dim p_names()
    Dim x_coord()
    Dim y_coord()
    Dim z_coord()
    
    ReDim p_names(ps.Count)     '名称格納
    ReDim x_coord(ps.Count)     'x座標格納
    ReDim y_coord(ps.Count)     'y座標格納
    ReDim z_coord(ps.Count)     'z座標格納
    
    Dim i As Long
    For i = 1 To ps.Count
        Set p = ps.Item(i)
        p_names(i) = p.Name
        x_coord(i) = p.x.Value
        y_coord(i) = p.y.Value
        z_coord(i) = p.z.Value
    Next i
    
 'Excel定義
    Dim appExcel As Object
    Set appExcel = CreateObject("Excel.Application")
    
    Dim wb As Workbook
    Set wb = appExcel.Workbooks.Add
    
    Dim ws As Worksheet
    Set ws = wb.Sheets.Item(1)
    
 'Excelに座標出力
    With ws
        .Cells(1, 1).Value = "名称"
        .Cells(1, 2).Value = "X座標"
        .Cells(1, 3).Value = "Y座標"
        .Cells(1, 4).Value = "Z座標"
        
        For i = 1 To ps.Count
            .Cells(i + 1, 1).Value = p_names(i)
            .Cells(i + 1, 2).Value = x_coord(i)
            .Cells(i + 1, 3).Value = y_coord(i)
            .Cells(i + 1, 4).Value = z_coord(i)
        Next i
        
    End With
    appExcel.Visible = True
    

 'UserForm表示
    UserForm1.Show
    
    
 'UserFormの[x]ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合
    If cancel_flg = True Then
        appExcel.DisplayAlerts = False
        wb.Close
        MsgBox "Canceled"
        Exit Sub
    End If
    
 '点の座標を更新
    With ws
        .Cells(1, 1).Select
        For i = 1 To ps.Count
            Set p = ps.Item(i)
            p.x.Value = .Cells(i + 1, 2).Value
            p.y.Value = .Cells(i + 1, 3).Value
            p.z.Value = .Cells(i + 1, 4).Value
            pt.UpdateObject p
        Next i
    End With
    
 '画面更新 & Excelﾌﾞｯｸを閉じる
    CATIA.RefreshDisplay = True
    appExcel.DisplayAlerts = False
    wb.Close
    MsgBox "done"

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

Option Explicit

Public cancel_flg As Boolean

Sub CATMain()

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

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

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

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

Exit Sub

End If

Dim doc As PartDocument

Set doc = CATIA.ActiveDocument

Dim sel 'As Selection

Set sel = doc.Selection

Dim pt As Part

Set pt = doc.Part

Dim hsf As HybridShapeFactory

Set hsf = pt.HybridShapeFactory

'形状ｾｯﾄ取得

Dim filter: filter = Array("HybridBody")

Dim res As String

res = sel.SelectElement2(filter, "Select Geometrical Set", False)

If res <> "Normal" Then

MsgBox "Canceled"

Exit Sub

End If

Dim hb As HybridBody

Set hb = sel.Item(1).Value

sel.Clear

'点(HybridShapePointCoord)取得

Dim ps As Collection

Set ps = New Collection

Dim hs

For Each hs In hb.HybridShapes

Dim p As HybridShapePointCoord

Set p = hs

ps.Add p

Next hs

'点の座標を配列に格納

Dim p_names()

Dim x_coord()

Dim y_coord()

Dim z_coord()

ReDim p_names(ps.Count) '名称格納

ReDim x_coord(ps.Count) 'x座標格納

ReDim y_coord(ps.Count) 'y座標格納

ReDim z_coord(ps.Count) 'z座標格納

Dim i As Long

For i = 1 To ps.Count

Set p = ps.Item(i)

p_names(i) = p.Name

x_coord(i) = p.x.Value

y_coord(i) = p.y.Value

z_coord(i) = p.z.Value

Next i

'Excel定義

Dim appExcel As Object

Set appExcel = CreateObject("Excel.Application")

Dim wb As Workbook

Set wb = appExcel.Workbooks.Add

Dim ws As Worksheet

Set ws = wb.Sheets.Item(1)

'Excelに座標出力

With ws

.Cells(1, 1).Value = "名称"

.Cells(1, 2).Value = "X座標"

.Cells(1, 3).Value = "Y座標"

.Cells(1, 4).Value = "Z座標"

For i = 1 To ps.Count

.Cells(i + 1, 1).Value = p_names(i)

.Cells(i + 1, 2).Value = x_coord(i)

.Cells(i + 1, 3).Value = y_coord(i)

.Cells(i + 1, 4).Value = z_coord(i)

Next i

End With

appExcel.Visible = True

'UserForm表示

UserForm1.Show

'UserFormの[x]ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合

If cancel_flg = True Then

appExcel.DisplayAlerts = False

wb.Close

MsgBox "Canceled"

Exit Sub

End If

'点の座標を更新

With ws

.Cells(1, 1).Select

For i = 1 To ps.Count

Set p = ps.Item(i)

p.x.Value = .Cells(i + 1, 2).Value

p.y.Value = .Cells(i + 1, 3).Value

p.z.Value = .Cells(i + 1, 4).Value

pt.UpdateObject p

Next i

End With

'画面更新 & Excelﾌﾞｯｸを閉じる

CATIA.RefreshDisplay = True

appExcel.DisplayAlerts = False

wb.Close

MsgBox "done"

End Sub

　
UserFormモジュールコード [UserForm1]

Option Explicit
Dim WithEvents cb1 As MSForms.CommandButton
Dim WithEvents cb2 As MSForms.CommandButton
'-----------------------------------------------------------------------------
Private Sub UserForm_Initialize()

 'UserFormｻｲｽﾞ変更
    With Me
        .Width = 95
        .Height = 90
    End With

 'CommandButton作成
    Set cb1 = Me.Controls.Add("Forms.CommandButton.1", "cb1", True)
    Set cb2 = Me.Controls.Add("Forms.CommandButton.1", "cb2", True)
    
 'CommandButtonｻｲｽﾞ/位置変更
    With cb1
        .Left = 10
        .Top = 10
        .Width = 75
        .Height = 20
        .Caption = "Run"
    End With
    
    With cb2
        .Left = 10
        .Top = 35
        .Width = 75
        .Height = 20
        .Caption = "Cancel"
    End With
    
End Sub
'-----------------------------------------------------------------------------
Private Sub cb1_Click()
    
    Unload Me

End Sub
'-----------------------------------------------------------------------------
Private Sub cb2_Click()
    
    cancel_flg = True
    Unload Me

End Sub
'-----------------------------------------------------------------------------
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    If CloseMode = 0 Then '[x]ボタンを押された場合
        cancel_flg = True
        Unload Me
    End If
    
End Sub

Option Explicit

Dim WithEvents cb1 As MSForms.CommandButton

Dim WithEvents cb2 As MSForms.CommandButton

'-----------------------------------------------------------------------------

Private Sub UserForm_Initialize()

'UserFormｻｲｽﾞ変更

With Me

.Width = 95

.Height = 90

End With

'CommandButton作成

Set cb1 = Me.Controls.Add("Forms.CommandButton.1", "cb1", True)

Set cb2 = Me.Controls.Add("Forms.CommandButton.1", "cb2", True)

'CommandButtonｻｲｽﾞ/位置変更

With cb1

.Left = 10

.Top = 10

.Width = 75

.Height = 20

.Caption = "Run"

End With

With cb2

.Left = 10

.Top = 35

.Width = 75

.Height = 20

.Caption = "Cancel"

End With

End Sub

'-----------------------------------------------------------------------------

Private Sub cb1_Click()

Unload Me

End Sub

'-----------------------------------------------------------------------------

Private Sub cb2_Click()

cancel_flg = True

Unload Me

End Sub

'-----------------------------------------------------------------------------

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

If CloseMode = 0 Then '[x]ボタンを押された場合

cancel_flg = True

Unload Me

End If

End Sub

コード解説

今回は標準モジュールとUserFormの両方にコードがあり長いので、重要部分のみを抜粋して解説していきます。解説が無くわからない部分があればお気軽に「お問い合わせ」よりご連絡ください。

点(HybridShapePointCoord)取得 [標準モジュール]

"] '点(HybridShapePointCoord)取得
    Dim ps As Collection
    Set ps = New Collection
    
    Dim hs 'ｵﾌﾞｼﾞｪｸﾄの型は設定不可
    For Each hs In hb.HybridShapes
        Dim p As HybridShapePointCoord
        Set p = hs
        ps.Add p
    Next hs

"] '点(HybridShapePointCoord)取得

Dim ps As Collection

Set ps = New Collection

Dim hs 'ｵﾌﾞｼﾞｪｸﾄの型は設定不可

For Each hs In hb.HybridShapes

Dim p As HybridShapePointCoord

Set p = hs

ps.Add p

Next hs

ここでは選択した形状セット内にある点を「ps」というコレクションに格納していきます。
このとき「ps.Add hs」とはせずに、いったん変数「p」に入れるという処理を挟みます。

For Each文を使用する時、オブジェクトの型の宣言をすることはできません。
しかし「ps.Add hs」と直接コレクションに格納すると型が間違えて格納される場合があります。
ここでは型の間違いが起きないよう「HybridShapePointCoord」として変数「p」を宣言し、確実にオブジェクトの種類を間違えないようにいったん変数を経由するという処理しています。

　
点の座標を配列に格納

    Dim i As Long
    For i = 1 To ps.Count
        Set p = ps.Item(i)
        p_names(i) = p.Name
        x_coord(i) = p.x.Value
        y_coord(i) = p.y.Value
        z_coord(i) = p.z.Value
    Next i

Dim i As Long

For i = 1 To ps.Count

Set p = ps.Item(i)

p_names(i) = p.Name

x_coord(i) = p.x.Value

y_coord(i) = p.y.Value

z_coord(i) = p.z.Value

Next i

ここでは「ps」コレクション内にある点の「名称」「X座標」「Y座標」「Z座標」をそれぞれ専用の配列に順に格納していっています。Excelに座標出力する時はここで格納したそれぞれの配列の中身を順に書き出していくだけの簡単な処理で済みます。

　
UserFormの[x]ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合

ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合"] 'UserForm表示
    UserForm1.Show
    
 'UserFormの[x]ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合
    If cancel_flg = True Then
        appExcel.DisplayAlerts = False
        wb.Close
        MsgBox "Canceled"
        Exit Sub
    End If

ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合"] 'UserForm表示

UserForm1.Show

'UserFormの[x]ﾎﾞﾀﾝ / [Cancel]ﾎﾞﾀﾝを押された場合

If cancel_flg = True Then

appExcel.DisplayAlerts = False

wb.Close

MsgBox "Canceled"

Exit Sub

End If

Excel上の座標の書き換えが完了した後は、再度プログラムの処理に戻します。
ここではそのトリガーとしてUserFormのCommandButtonを採用しています。

CommandButtonの[Run]が押されればそのまま処理を継続、
[Cancel]もしくは[x]ボタンが押されたらマクロを中断するようにします。

この処理を取り入れるため標準モジュールの最初にPublicで「cancel_flg」というBoolean型の変数を用意しています。UserFormの表示は「vbModeless」ではない通常表示ため、UserFormが閉じるまで次の処理には進まないようになっています。

そこでUserForm側のコードで[Cancel]もしくは[x]ボタンが押された場合は「cancel_flg」を「True」にするという処理を入れています。つまりUserFormが閉じた時「cancel_flg」がFalse([Run]ボタン押下)の場合のみマクロの処理を継続するような条件分岐をさせているというわけです。

　
点の座標を更新

 '点の座標を更新
    With ws
        .Cells(1, 1).Select
        For i = 1 To ps.Count
            Set p = ps.Item(i)
            p.x.Value = .Cells(i + 1, 2).Value
            p.y.Value = .Cells(i + 1, 3).Value
            p.z.Value = .Cells(i + 1, 4).Value
            pt.UpdateObject p
        Next i
    End With