CATPartの座標系をPowerPointオブジェクトとして作成するマクロ｜CATIAマクロの作成方法

CATIAを使って仕事をしている人の多くは、CATIAだけでなくOffice系のソフトとあわせて使う機会があると思います。

その中でもCATIAとExcelを連携させたマクロはよく見るのですが、CATIAとPowerPointを連携させたマクロはあまり見かけないような気がします。(CATIAとPowerPointを連携する必要が無いためだと思いますが)

というわけで今回は個人的に欲しかった
「CATPartの座標系をPowerPointオブジェクトとして作成するマクロ」を作成したので簡単に紹介していきます。

PowerPointとCATIAを連携させようとしている方はぜひ参考にしてみて下さい。

※今回はメモ書き程度の内容なのであまり深い説明はしていません。

マクロの機能

マクロの機能は至ってシンプルで
「アクティブなCATPartの座標系をPowerPoint上に作成する」というものです。

PowerPointの「矢印」と「テキストボックス」を使って上画像のような座標系を作成し、
最終的にはグールプ化してスライド中心に配置するようになっています。

マクロの機能としてはかなりシンプルなものとなっていますが、処理の内容はかなり長めです。

サンプルコード

PowerPointファイルを開いた状態で以下のコードを実行すれば、
マクロ実行時のCATPartの座標系がスライド上に作成されます。
基本的にはコピペで実行可能ですが、場合によってはうまく作動しない可能性もあります。
(PowerPointマクロのコードはあまり書く機会がないのでエラーが出るとすれば恐らくPowerPoint部)

※Excel同様、PowerPointライブラリを読み込ませる必要があります。
　詳しくは「CATIAマクロでPowerPointを操作する方法」を参照ください。

Option Explicit
Sub CATMain()
On Error GoTo myError

Dim DOC As PartDocument
                                            
If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
   MsgBox "このマクロはPartDocument専用です。" _
            & vbLf & _
          "ワークベンチを切り替えてから実行してください。"
   Exit Sub
End If

Set DOC = CATIA.ActiveDocument

Dim PT As Part
Set PT = DOC.Part

Dim HSF As HybridShapeFactory
Set HSF = PT.HybridShapeFactory

Dim HB As HybridBody
Set HB = PT.HybridBodies.Add
HB.Name = "残っていたら形状ｾｯﾄごと削除してください"

Dim AXS As AxisSystem
Set AXS = PT.AxisSystems.Add

Dim Origin As Point
Set Origin = HSF.AddNewPointCoord(0#, 0#, 0#)

HB.AppendHybridShape Origin

PT.Update


'*****************************************************
'     　　　 スクリーン基準での平面作成
'*****************************************************
Dim WIN As Window
Set WIN = CATIA.ActiveWindow

Dim VIW As Viewer
Set VIW = WIN.ActiveViewer

Dim VIW3D 'As Viewpoint3D
Set VIW3D = VIW.Viewpoint3D

Dim SightDirection(2)
VIW3D.GetSightDirection SightDirection  '視点の視線方向の成分(=スクリーンに対して平行となる成分)を取得

Dim UpDirection(2)
VIW3D.GetUpDirection UpDirection        '視点の上方向の成分(=スクリーンに対して上方向となる成分)を取得


Dim RefPoint As Reference
Set RefPoint = PT.CreateReferenceFromObject(Origin)

Dim ParaPLN As HybridShapePlaneEquation
Set ParaPLN = HSF.AddNewPlaneEquation(SightDirection(0), SightDirection(1), SightDirection(2), 20#)
ParaPLN.SetReferencePoint RefPoint

HB.AppendHybridShape ParaPLN
PT.Update

Dim VerPLN As HybridShapePlaneEquation
Set VerPLN = HSF.AddNewPlaneEquation(UpDirection(0), UpDirection(1), UpDirection(2), 20#)
VerPLN.SetReferencePoint RefPoint

HB.AppendHybridShape VerPLN
PT.Update


'*****************************************************
'        　　　X,Y,Z軸方向に直線作成
'*****************************************************

Dim RefPLN1 As Reference
Set RefPLN1 = PT.CreateReferenceFromObject(ParaPLN)

Dim XDirection As HybridShapeDirection
Set XDirection = HSF.AddNewDirectionByCoord(1#, 0#, 0#)

Dim XLine As HybridShapeLinePtDir
Set XLine = HSF.AddNewLinePtDir(RefPoint, XDirection, 0#, 100#, False)  '原点からX軸方向に100mmの直線
HB.AppendHybridShape XLine
PT.Update


Dim YDirection As HybridShapeDirection
Set YDirection = HSF.AddNewDirectionByCoord(0#, 1#, 0#)

Dim YLine As HybridShapeLinePtDir
Set YLine = HSF.AddNewLinePtDir(RefPoint, YDirection, 0#, 100#, False)  '原点からY軸方向に100mmの直線
HB.AppendHybridShape YLine
PT.Update


Dim ZDirection As HybridShapeDirection
Set ZDirection = HSF.AddNewDirectionByCoord(0#, 0#, 1#)

Dim ZLine As HybridShapeLinePtDir
Set ZLine = HSF.AddNewLinePtDir(RefPoint, ZDirection, 0#, 100#, False)  '原点からZ軸方向に100mmの直線
HB.AppendHybridShape ZLine
PT.Update


'*****************************************************
'     　　　　 スクリーン方向に直線作成
'*****************************************************

Dim RefPLN2 As Reference
Set RefPLN2 = PT.CreateReferenceFromObject(VerPLN)

Dim VerDirection As HybridShapeDirection
Set VerDirection = HSF.AddNewDirection(RefPLN2)

Dim VerLine As HybridShapeLinePtDir
Set VerLine = HSF.AddNewLinePtDirOnSupport(RefPoint, VerDirection, RefPLN1, 0#, 100#, False)  '原点からスクリーン上方向に100mmの直線
HB.AppendHybridShape VerLine
PT.Update


Dim RefLine As Reference
Set RefLine = PT.CreateReferenceFromObject(VerLine)

Dim HorLine As HybridShapeLineAngle
Set HorLine = HSF.AddNewLineAngle(RefLine, RefPLN1, RefPoint, False, 0#, 100#, 90#, False)   '原点からスクリーン右方向に100mmの直線
HB.AppendHybridShape HorLine
PT.Update


'*****************************************************
'        スクリーン基準のローカル座標系作成
'*****************************************************

Dim ScreenAXS As AxisSystem
Set ScreenAXS = PT.AxisSystems.Add()

Dim RefScreenX As Reference
Set RefScreenX = PT.CreateReferenceFromObject(HorLine)

Dim RefScreenY As Reference
Set RefScreenY = PT.CreateReferenceFromObject(VerLine)

ScreenAXS.OriginPoint = RefPoint
ScreenAXS.XAxisDirection = RefScreenX  'スクリーン右方向をX軸
ScreenAXS.YAxisDirection = RefScreenY  'スクリーン上方向をY軸とする座標系を作成

PT.Update



'*****************************************************
'           　　 座標取得用の点作成
'*****************************************************

'*** X,Y,Z方向の直線の端点を作成 ***

Dim RefXLine As Reference
Set RefXLine = PT.CreateReferenceFromGeometry(XLine)
Dim XPoint As HybridShapePointOnCurve
Set XPoint = HSF.AddNewPointOnCurveFromPercent(RefXLine, 1, False)
HB.AppendHybridShape XPoint
PT.Update

Dim RefYLine As Reference
Set RefYLine = PT.CreateReferenceFromGeometry(YLine)
Dim YPoint As HybridShapePointOnCurve
Set YPoint = HSF.AddNewPointOnCurveFromPercent(RefYLine, 1, False)
HB.AppendHybridShape YPoint
PT.Update

Dim RefZLine As Reference
Set RefZLine = PT.CreateReferenceFromGeometry(ZLine)
Dim ZPoint As HybridShapePointOnCurve
Set ZPoint = HSF.AddNewPointOnCurveFromPercent(RefZLine, 1, False)
HB.AppendHybridShape ZPoint
PT.Update


'*** 端点をスクリーンに平行な平面に投影 ***

Dim RefXPoint As Reference
Set RefXPoint = PT.CreateReferenceFromObject(XPoint)
Dim XPro As HybridShapeProject
Set XPro = ProjectionPoint(PT, HB, RefXPoint, RefPLN1)


Dim RefYPoint As Reference
Set RefYPoint = PT.CreateReferenceFromObject(YPoint)
Dim YPro As HybridShapeProject
Set YPro = ProjectionPoint(PT, HB, RefYPoint, RefPLN1)

Dim RefZPoint As Reference
Set RefZPoint = PT.CreateReferenceFromObject(ZPoint)
Dim ZPro As HybridShapeProject
Set ZPro = ProjectionPoint(PT, HB, RefZPoint, RefPLN1)


'*** 投影した点をデータム化(投影した点を「As HybridShapeProject」を「As Point」にするため)***

Dim IsoXPro As Point
Set IsoXPro = HSF.AddNewPointDatum(XPro)
HB.AppendHybridShape IsoXPro

Dim IsoYPro As Point
Set IsoYPro = HSF.AddNewPointDatum(YPro)
HB.AppendHybridShape IsoYPro

Dim IsoZPro As Point
Set IsoZPro = HSF.AddNewPointDatum(ZPro)
HB.AppendHybridShape IsoZPro

PT.Update



'*************************************************************************
'  　　　絶対座標系基準の座標をローカル座標系基準の座標に変換
'*************************************************************************

Dim LocalAXS As Variant ' <- check
Set LocalAXS = ScreenAXS

Dim axisOrigin(2)
Dim xVect(2), yVect(2), zVect(2)
LocalAXS.GetOrigin (axisOrigin)
LocalAXS.GetXAxis (xVect)
LocalAXS.GetYAxis (yVect)
LocalAXS.GetZAxis (zVect)

'these vectors need to be normalized
NormalizeVector xVect, xVect
NormalizeVector yVect, yVect
NormalizeVector zVect, zVect

Dim globalCoords(2)
Dim delta(2)
Dim csCoords(2)
Dim AxisPoint As Variant


Dim XDirCoords(2)   '|
Dim YDirCoords(2)   '|  座標変換後のアウトプット用配列
Dim ZDirCoords(2)   '|

Dim AxisPoints As Collection
Set AxisPoints = New Collection

AxisPoints.Add IsoXPro
AxisPoints.Add IsoYPro
AxisPoints.Add IsoZPro

Dim i As Integer
For i = 1 To AxisPoints.Count

    Set AxisPoint = AxisPoints.Item(i)
    
    AxisPoint.GetCoordinates (globalCoords)

    delta(0) = globalCoords(0) - axisOrigin(0)
    delta(1) = globalCoords(1) - axisOrigin(1)
    delta(2) = globalCoords(2) - axisOrigin(2)

    csCoords(0) = DotProduct(delta, xVect)
    csCoords(1) = DotProduct(delta, yVect)
    csCoords(2) = DotProduct(delta, zVect)
    
    If i = 1 Then
        XDirCoords(0) = Format(DotProduct(delta, xVect), "0.000")
        XDirCoords(1) = Format(DotProduct(delta, yVect), "0.000")
        XDirCoords(2) = Format(DotProduct(delta, zVect), "0.000")
    ElseIf i = 2 Then
        YDirCoords(0) = Format(DotProduct(delta, xVect), "0.000")
        YDirCoords(1) = Format(DotProduct(delta, yVect), "0.000")
        YDirCoords(2) = Format(DotProduct(delta, zVect), "0.000")
    ElseIf i = 3 Then
        ZDirCoords(0) = Format(DotProduct(delta, xVect), "0.000")
        ZDirCoords(1) = Format(DotProduct(delta, yVect), "0.000")
        ZDirCoords(2) = Format(DotProduct(delta, zVect), "0.000")
    End If

Next i


'*****************************************************
'      作成するテキストボックスの中心座標を指定
'*****************************************************

Dim XDirX As Single
Dim XDirY As Single
Dim YDirX As Single
Dim YDirY As Single
Dim ZDirX As Single
Dim ZDirY As Single

Dim Mar As Single
Mar = 15    '矢印とテキストボックスの距離を指定

On Error Resume Next
XDirX = (XDirCoords(0) / Sqr(XDirCoords(0) * XDirCoords(0) + XDirCoords(1) * XDirCoords(1))) * (Sqr(XDirCoords(0) * XDirCoords(0) + XDirCoords(1) * XDirCoords(1)) + Mar)
XDirY = (XDirCoords(1) / Sqr(XDirCoords(0) * XDirCoords(0) + XDirCoords(1) * XDirCoords(1))) * (Sqr(XDirCoords(0) * XDirCoords(0) + XDirCoords(1) * XDirCoords(1)) + Mar)

YDirX = (YDirCoords(0) / Sqr(YDirCoords(0) * YDirCoords(0) + YDirCoords(1) * YDirCoords(1))) * (Sqr(YDirCoords(0) * YDirCoords(0) + YDirCoords(1) * YDirCoords(1)) + Mar)
YDirY = (YDirCoords(1) / Sqr(YDirCoords(0) * YDirCoords(0) + YDirCoords(1) * YDirCoords(1))) * (Sqr(YDirCoords(0) * YDirCoords(0) + YDirCoords(1) * YDirCoords(1)) + Mar)

ZDirX = (ZDirCoords(0) / Sqr(ZDirCoords(0) * ZDirCoords(0) + ZDirCoords(1) * ZDirCoords(1))) * (Sqr(ZDirCoords(0) * ZDirCoords(0) + ZDirCoords(1) * ZDirCoords(1)) + Mar)
ZDirY = (ZDirCoords(1) / Sqr(ZDirCoords(0) * ZDirCoords(0) + ZDirCoords(1) * ZDirCoords(1))) * (Sqr(ZDirCoords(0) * ZDirCoords(0) + ZDirCoords(1) * ZDirCoords(1)) + Mar)
On Error GoTo myError


'************************************************************************
'     作成するテキストボックスのアンカーポイント(左上)の座標を指定
'************************************************************************

Dim XAncX As Single
Dim XAncY As Single
Dim YAncX As Single
Dim YAncY As Single
Dim ZAncX As Single
Dim ZAncY As Single

Dim TransX As Single
Dim TransY As Single
TransX = -15  'テキストボックスの位置調整(左右方向)
TransY = 22   'テキストボックスの位置調整(上下方向)

XAncX = XDirX + TransX
XAncY = XDirY + TransY
YAncX = YDirX + TransX
YAncY = YDirY + TransY
ZAncX = ZDirX + TransX
ZAncY = ZDirY + TransY


'*****************************************************
'           作成してきたオブジェクト全削除
'*****************************************************

Dim SEL As Selection
Set SEL = DOC.Selection

SEL.Clear
SEL.Add HB
SEL.Delete
PT.Update




'*****************************************************
'
'
'              　 PowerPoint操作
'
'
'*****************************************************

Dim appPPT As PowerPoint.Application

On Error Resume Next
Set appPPT = GetObject(, "PowerPoint.Application") 'PowerPint定義
On Error GoTo myError

If appPPT Is Nothing Then
    MsgBox ("PowerPointを開いてから実行してください。")
    Exit Sub  'PowerPointが開かれていない場合はマクロを中断
End If

Dim PP 'As Presentation
Set PP = appPPT.Presentations(appPPT.ActiveWindow.Presentation.Name)  'アクティブなプレゼンテーションを取得

Dim ActSldIndex As Integer
ActSldIndex = appPPT.ActiveWindow.Selection.SlideRange.SlideNumber  'アクティブなスライド番号を取得

Dim ActSld As Slide
Set ActSld = PP.Slides.Item(ActSldIndex) 'アクティブなスライドを取得

Dim SPs 'As Shapes
Set SPs = ActSld.Shapes


'*****************************************************
'          　　矢印/テキストボックス作成
'*****************************************************

Dim ArrowSize As Single
ArrowSize = 0.7    ' 作成するPowerPointオブジェクトのサイズ調整用


If Not (XDirCoords(0) = 0 And XDirCoords(1) = 0) Then
    Dim XArrow 'As Shape
    Set XArrow = SPs.AddLine(0, 0, (XDirCoords(0) * ArrowSize), -(XDirCoords(1) * ArrowSize))
    With XArrow.Line
        .EndArrowheadStyle = 3
        .ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Dim XTextBox 'As Shape
    Set XTextBox = SPs.AddTextbox(1, (XAncX * ArrowSize), -(XAncY * ArrowSize), 100, 100)
    With XTextBox.TextFrame
        .WordWrap = 0
        .HorizontalAnchor = 2
        .VerticalAnchor = 1
        .TextRange.Text = "X"
        .AutoSize = 1
    End With
    
End If

If Not (YDirCoords(0) = 0 And YDirCoords(1) = 0) Then
    Dim YArrow 'As Shape
    Set YArrow = SPs.AddLine(0, 0, (YDirCoords(0) * ArrowSize), -(YDirCoords(1) * ArrowSize))
    With YArrow.Line
        .EndArrowheadStyle = 3
        .ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Dim YTextBox 'As Shape
    Set YTextBox = SPs.AddTextbox(1, (YAncX * ArrowSize), -(YAncY * ArrowSize), 100, 100)
    With YTextBox.TextFrame
        .WordWrap = 0
        .HorizontalAnchor = 2
        .VerticalAnchor = 1
        .TextRange.Text = "Y"
        .AutoSize = 1
    End With
    
End If

If Not (ZDirCoords(0) = 0 And ZDirCoords(1) = 0) Then
    Dim ZArrow 'As Shape
    Set ZArrow = SPs.AddLine(0, 0, (ZDirCoords(0) * ArrowSize), -(ZDirCoords(1) * ArrowSize))
    With ZArrow.Line
        .EndArrowheadStyle = 3
        .ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Dim ZTextBox 'As Shape
    Set ZTextBox = SPs.AddTextbox(1, (ZAncX * ArrowSize), -(ZAncY * ArrowSize), 100, 100)
    With ZTextBox.TextFrame
        .WordWrap = 0
        .HorizontalAnchor = 2
        .VerticalAnchor = 1
        .TextRange.Text = "Z"
        .AutoSize = 1
    End With
    
End If


'*****************************************************
'                   グループ化
'*****************************************************

appPPT.ActiveWindow.Selection.Unselect


Dim Arrow1 'As Shape
Dim Arrow2 'As Shape
Dim Arrow3 'As Shape
Dim Text1 'As Shape
Dim Text2 'As Shape
Dim Text3 'As Shape
Dim ShpCnt As Long

If (XDirCoords(0) = 0 And XDirCoords(1) = 0) Or _
   (YDirCoords(0) = 0 And YDirCoords(1) = 0) Or _
   (ZDirCoords(0) = 0 And ZDirCoords(1) = 0) Then

    With appPPT.ActiveWindow.Selection.SlideRange.Shapes
        ShpCnt = .Count
        
        Set Arrow1 = .Item(ShpCnt - 3)
        Arrow1.Select Replace:=False
        
        Set Text1 = .Item(ShpCnt - 2)
        Text1.Select Replace:=False

        Set Arrow2 = .Item(ShpCnt - 1)
        Arrow2.Select Replace:=False
        
        Set Text2 = .Item(ShpCnt)
        Text2.Select Replace:=False
        
    End With
    
Else

    With appPPT.ActiveWindow.Selection.SlideRange.Shapes
        ShpCnt = .Count
    
        Set Arrow1 = .Item(ShpCnt - 5)
        Arrow1.Select Replace:=False
        
        Set Text1 = .Item(ShpCnt - 4)
        Text1.Select Replace:=False

        Set Arrow2 = .Item(ShpCnt - 3)
        Arrow2.Select Replace:=False
        
        Set Text2 = .Item(ShpCnt - 2)
        Text2.Select Replace:=False

        Set Arrow3 = .Item(ShpCnt - 1)
        Arrow3.Select Replace:=False
        
        Set Text3 = .Item(ShpCnt)
        Text3.Select Replace:=False
        
    End With
    
End If

appPPT.ActiveWindow.Selection.ShapeRange.Group

With appPPT.ActiveWindow.Selection.SlideRange.Shapes
     ShpCnt = .Count

     Dim AxisGrp 'As Shape
     Set AxisGrp = .Item(ShpCnt)
     AxisGrp.Select Replace:=True

End With


'*****************************************************
'    グループ化した座標系をスライド中心に配置する
'*****************************************************

Dim sld_w As Single  'スライドの横幅
Dim sld_h As Single  'スライドの高さ
Dim shp_w As Single  'Shapeの横幅
Dim shp_h As Single  'Shapeの高さ

With appPPT.ActiveWindow.Selection

  'スライドのサイズを取得
  sld_w = .SlideRange.Master.Width
  sld_h = .SlideRange.Master.Height

  '図形のサイズを取得
  shp_w = .ShapeRange.Width
  shp_h = .ShapeRange.Height

  '図形の位置を移動
  .ShapeRange.Left = (sld_w - shp_w) / 2
  .ShapeRange.Top = (sld_h - shp_h) / 2

End With

MsgBox "PowerPointに絶対座標系を書き出しました。"
appPPT.ActiveWindow.Activate  'PowerPointをウィンドウ最前面にする

Exit Sub

myError:
    MsgBox "予期せぬエラーが発生しました"
End Sub
'------------------------------------------------------------------------------------------------
Private Function ProjectionPoint(PT As Part, _
                                 HB As HybridBody, _
                                 RefPoint As Reference, _
                                 RefPLN As Reference) As HybridShapeProject

Dim Project As HybridShapeProject
Set Project = PT.HybridShapeFactory.AddNewProject(RefPoint, RefPLN)
Project.SolutionType = 0
Project.Normal = True
Project.SmoothingType = 0

HB.AppendHybridShape Project
PT.Update

Set ProjectionPoint = Project

End Function
'------------------------------------------------------------------------------------------------
Public Function DotProduct(vect1(), vect2()) As Double
DotProduct = vect1(0) * vect2(0) + vect1(1) * vect2(1) + vect1(2) * vect2(2)
End Function
'------------------------------------------------------------------------------------------------
Public Sub NormalizeVector(invect(), ByRef normvect())
Dim mag As Double
mag = Sqr(invect(0) * invect(0) + invect(1) * invect(1) + invect(2) * invect(2))
If mag < 0.0000001 Then Call Err.Raise(1001, , "Zero length vector cannot be normalized")
normvect(0) = invect(0) / mag
normvect(1) = invect(1) / mag
normvect(2) = invect(2) / mag
End Sub

　
※今回はコードが非常に長いため、コード解説は割愛します。
コード内にコメントで簡単な説明を記しておくので参考にしてください。

まとめ

今回はCATIAとPowerPointを連携したサンプルマクロの紹介内容でした。

あまり需要もないと思うのでメモ書き程度の内容となっています。
もし「詳しくコード内容を教えてほしい」という方がいましたら「お問い合わせ」からご連絡ください。

目次へ戻る
 

icon-book 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ショッピング