C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

指定した2D要素を、指定した原点位置でｺﾋﾟﾍﾟする

CATIA_V5 VBA KCL

DXF(2D)ﾃﾞｰﾀを受け取って3Dにﾓﾃﾞﾘﾝｸﾞする作業は、ほぼ無いのですが
大まかな形状を作成したい時が偶にあり、行います。

DXFをｲﾝﾎﾟｰﾄして手っ取り早く、3Dに貼り付けたいのですが困るのが
原点合わせです。　Draw側で原点をあわせて3Dにﾍﾞﾀｯと貼り付けるか?
3Dにﾍﾞﾀｯと貼り付けた後に、ｽｹｯﾁで原点をあわせるか?
どちらにしても、個人的にはCATIAの2Dの移動ｺﾏﾝﾄﾞが、異常な程
使いにくく感じてます。

この作業を補助するﾏｸﾛを過去に "Unofficial CATIA User Forum" で
Upしたのですが、あまりにｺｰﾄﾞが汚かったため再度直したものです。

指定した2D要素を指定した原点位置を元に、新たなﾋﾞｭｰにｺﾋﾟﾍﾟする
ﾏｸﾛです。

'vba sample_Draw_CloneGeo2D ver0.0.2  using-'KCL0.09'
'選択したDraw2D要素を新たなViewにｺﾋﾟﾍﾟします。
'2Dｺﾝﾎﾟｰﾈﾝﾄは選択出来ないので、事前に展開してください

Private Const DBL_MAX = 1.79769313486231E+308       'Double Max
Private Const EPS = 0.0001                          'ｲｺｰﾙ判断
Private Const OFFSET = 50                           '他ﾋﾞｭｰとの距離

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub

    '準備
    Dim Doc As DrawingDocument: Set Doc = CATIA.ActiveDocument
    Dim ActSheet As DrawingSheet: Set ActSheet = Doc.Sheets.ActiveSheet
    Dim PastePos: PastePos = GetPasteBasePos(ActSheet)
    
    '作業ｽﾀｰﾄ
    Dim OriPos
    Dim Sel As Selection
    Dim CloneView As DrawingView
    Dim CloneRngBox
    
    CATIA.HSOSynchronized = False
    Dim TmpSheet As DrawingSheet '一時作業用
    Set TmpSheet = GetNewDetailSheet()
    Do
        'ｺﾋﾟｰ要素選択
        Set Sel = SeledItems("ｺﾋﾟｰ要素選択 // [Esc]=ｷｬﾝｾﾙ")
        If KCL.IsNothing(Sel) Then Exit Do
        Sel.Copy
        
        '原点要素選択
        Do
            Set Sel = SeledItems("原点要素を選択 // [Esc]=ｺﾋﾟｰ要素再選択")
            If KCL.IsNothing(Sel) Then GoTo Continue
            
            OriPos = GetOrigin(Sel) '原点取得
            If IsEmpty(OriPos) Then
                Call SelectOriginErrMsg
            Else
                Exit Do
            End If
        Loop
        
        'ﾍﾟｰｽﾄ作業
        Set CloneView = GetCloneView(ActSheet, TmpSheet, OriPos)
        
        'ﾋﾞｭｰの移動
        CloneRngBox = GetViewRngBox(CloneView)
        CloneView.x = PastePos(0) + (CloneRngBox(0)(0) * -1)
        CloneView.y = PastePos(1) + (CloneRngBox(1)(1) * -1) - OFFSET
        
        'ﾍﾟｰｽﾄ位置更新
        PastePos(0) = PastePos(0) + OFFSET + _
                      (CloneRngBox(1)(0) - CloneRngBox(0)(0))
Continue:
    Loop
    CATIA.HSOSynchronized = True
    
    '一時的なﾃﾞｨﾃｰﾙｼｰﾄ削除
    With Doc.Selection
        .Clear
        .Add TmpSheet
        .Delete
    End With
End Sub

'原点取得
Private Function GetOrigin(ByVal Sel As Selection) As Variant
    GetOrigin = Empty
    Select Case Sel.Count2
        Case 0
            Exit Function
        Case 1
            GetOrigin = GetOrigin_Single(Sel.Item2(1).value)
        Case Else
            GetOrigin = GetOrigin_Multi( _
                            Array(Sel.Item2(1).value, _
                                  Sel.Item2(2).value))
    End Select
End Function

'原点取得-1個
Private Function GetOrigin_Single(ByVal Geo2D As Geometry2D) As Variant
    GetOrigin_Single = Empty
    
    Select Case Geo2D.GeometricType
        Case catGeoTypePoint2D '点
            GetOrigin_Single = toPos(Geo2D)
            
        Case catGeoTypeCircle2D '円弧
            GetOrigin_Single = toPos(Geo2D.CenterPoint)
        
    End Select
End Function

'原点取得-2個以上
Private Function GetOrigin_Multi(ByVal Geo2D As Variant) As Variant
    GetOrigin_Multi = Empty
    
    '直線ﾁｪｯｸ
    Dim i&
    For i = 0 To 1
        If Not (Geo2D(i).GeometricType = catGeoTypeLine2D) Then Exit Function
    Next
    
    '端点取得
    Dim St(1), Ed(1), Pos(1)
    For i = 0 To 1
        Call Geo2D(i).GetOrigin(Pos)
        St(i) = Pos
        Call Geo2D(i).GetDirection(Pos)
        Ed(i) = Sum2d(St(i), Pos)
    Next
    
    '交点取得
    Dim IntPos: IntPos = Intersect2d(St(0), Ed(0), St(1), Ed(1))
    If IsEmpty(IntPos) Then Exit Function
    
    GetOrigin_Multi = IntPos
End Function

'Point2Dから座標値取得
Private Function toPos(Pnt As Variant) As Variant
    Dim Pos(1): Call Pnt.GetCoordinates(Pos)
    toPos = Pos
End Function

'原点取得Ngﾒｯｾｰｼﾞ
Private Sub SelectOriginErrMsg()
    Dim Msg$
    Msg = "原点となる要素は" & vbNewLine & _
          "1個 - 点、円弧" & vbNewLine & _
          "2個 - 直線(平行な線はNG)" & vbNewLine & _
          "としてください"
    MsgBox Msg, vbOKOnly + vbInformation
End Sub

'ﾃﾞｨﾃｰﾙｼｰﾄ作成
Private Function GetNewDetailSheet() As DrawingSheet
    Dim Sheets As DrawingSheets: Set Sheets = CATIA.ActiveDocument.Sheets
    Dim Act As DrawingSheet: Set Act = Sheets.ActiveSheet
    Set GetNewDetailSheet = Sheets.AddDetail("AutomaticNaming")
    Act.Activate
End Function

'ﾍﾟｰｽﾄ
Private Function GetCloneView(ByVal TargetSheet As DrawingSheet, _
                              ByVal Detail As DrawingSheet, ByVal Origin)
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    
    'ﾃﾞｨﾃｰﾙｼｰﾄにﾍﾟｰｽﾄ
    Dim DetailView As DrawingView
    Set DetailView = Detail.Views.Add("AutomaticNaming")
    With Sel
        .Clear
        .Add DetailView
        .Paste
    End With
    
    'ﾍﾟｰｽﾄﾋﾞｭｰ
    Dim CloneView As DrawingView
    Set CloneView = TargetSheet.Views.Add("AutomaticNaming")
    
    'ｺﾝﾎﾟｰﾈﾝﾄ化-分解
    Dim Comp As DrawingComponent
    Set Comp = CloneView.Components.Add(DetailView, _
                                        Origin(0) * -1, Origin(1) * -1)
    Call Comp.Explode
    
    '不要ﾃﾞｰﾀ削除
    With Sel
        .Clear
        .Add DetailView
        .Delete
    End With
    
    Set GetCloneView = CloneView
End Function

'ﾍﾟｰｽﾄ基準位置
''' @return:array(long) 0-X, 1-Y
Private Function GetPasteBasePos(ByVal Sheet As DrawingSheet) As Variant
    Dim Vws As DrawingViews: Set Vws = Sheet.Views
    Dim ViewEnum As Collection: Set ViewEnum = InitRangeList(1, Vws.count)
    Call ViewEnum.Remove(2) '背景は無視
    
    Dim MinPos: MinPos = Array(DBL_MAX, DBL_MAX)
    Dim i, RngBox
    For Each i In ViewEnum
        RngBox = GetViewRngBox(Vws.Item(i))
        If MinPos(0) > RngBox(0)(0) Then MinPos(0) = RngBox(0)(0)
        If MinPos(1) > RngBox(0)(1) Then MinPos(1) = RngBox(0)(1)
    Next
    GetPasteBasePos = MinPos
End Function

'Viewのｻｲｽﾞ取得
''' @return:array(array(long),array(long)) 00-Xmin, 01-Ymin, 10-Xmax, 11-Ymax
Private Function GetViewRngBox(View) As Variant 'View As DrawingView)
    Dim Pos(4): Call View.Size(Pos)
    GetViewRngBox = Array(Array(Pos(0), Pos(2)), Array(Pos(1), Pos(3)))
End Function

'選択
''' @param:Msg-ﾒｯｾｰｼﾞ
''' @return:Selection
Private Function SeledItems(ByVal Msg$) As Selection
    Set SeledItems = Nothing
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement3(Array("Geometry2D"), Msg, True, _
                    CATMultiSelTriggWhenUserValidatesSelection, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SeledItems = Sel
End Function

'初期化済みｺﾚｸｼｮﾝ生成
Private Function InitRangeList(ByVal Min&, ByVal Max&) As Collection
    Dim List As Collection: Set List = New Collection
    Dim i&
    For i = Min To Max
        List.Add i
    Next
    Set InitRangeList = List
End Function

'*** math ***
'和2D
Private Function Sum2d(ByVal a, ByVal b) As Variant
    Sum2d = Array(a(0) + b(0), a(1) + b(1))
End Function

'差2D
Private Function Sub2d(ByVal a, ByVal b) As Variant
    Sub2d = Array(a(0) - b(0), a(1) - b(1))
End Function

'内積2D
Private Function Dot2d(ByVal a, ByVal b) As Double
    Dot2d = a(0) * b(0) + a(1) * b(1)
End Function

'外積2D
Private Function Cross2d(ByVal a, ByVal b) As Double
    Cross2d = a(0) * b(1) - a(1) * b(0)
End Function

'交点 a1-a2とb1-b2
Private Function Intersect2d(ByVal a1, ByVal a2, ByVal b1, ByVal b2)
    Intersect2d = Empty
    If isParallel(a1, a2, b1, b2) Then Exit Function
    Dim a: a = Sub2d(a2, a1)
    Dim b: b = Sub2d(b2, b1)
    Dim c#: c = Cross2d(b, Sub2d(b1, a1)) / Cross2d(b, a)
    a(0) = a(0) * c
    a(1) = a(1) * c
    Intersect2d = Sum2d(a1, a)
End Function

'丸め誤差を考慮し、公差を設けたイコール判定
Private Function EQ(ByVal a As Double, ByVal b As Double) As Boolean
    EQ = IIf(Abs((a) - (b)) < EPS, True, False)
End Function

'平行判定 a1-a2とb1-b2
Private Function isParallel(ByVal a1, ByVal a2, ByVal b1, ByVal b2) As Boolean
    isParallel = EQ(Cross2d(Sub2d(a1, a2), Sub2d(b1, b2)), 0#)
End Function

利用方法です。ｻﾝﾌﾟﾙﾃﾞｰﾀのDXFをｲﾝﾎﾟｰﾄした状態はこんな感じです。
f:id:kandennti:20170120185124p:plain
これ、僕が作ったわけじゃないです。GrabCADのこちらをお借りしました。
GrabCAD - CAD library
今更ながら、ｻﾝﾌﾟﾙとしては現実味が無さすぎです･･･。

原点はこんなところにあります。
f:id:kandennti:20170120185131p:plain


ﾏｸﾛ実行後、まずｺﾋﾟｰする要素を選択します。複数選択が可能なので
ﾗﾊﾞｰﾊﾞﾝﾄﾞやCtrlｷｰと併用して頂くと複数選択できます。
f:id:kandennti:20170120185140p:plain
"ﾂｰﾙﾊﾟﾚｯﾄ" ﾂｰﾙﾊﾞｰが出てくるので、選択した状態のまま一番右の
"完了" ﾎﾞﾀﾝで決定です。


続いて原点となる要素の選択です。手順はｺﾋﾟｰする要素を選択と
同じなのですが、選択要素によって原点の決定方法が異なります。

○1個だけ選択
　・点 - 点の位置を原点とします。
　・円弧 - 円弧の中心を原点とします。

○2個以上を選択　（2個以上選択しても、最初の2個だけで判断します）
　・両方直線 - 交点を原点とします。

他の場合は、再度原点要素の指定となります。


原点決定後は、ｺﾋﾟﾍﾟ処理を行います。出来上がるﾋﾞｭｰは他のﾋﾞｭｰと
重ならないように、左下の位置から右側に順次ｺﾋﾟﾍﾟしていきます。
f:id:kandennti:20170120185152p:plain

一度では終わらない事が多いため、ESCｷｰが入力されるまで繰り返されます。


これ、原点指定の2本の直線を選択した際、交差していなくても
交点を求めて、原点として設定してます。

こんな感じで選択し
f:id:kandennti:20170120185201p:plain

こんな感じで原点指定の要素を選択すると
f:id:kandennti:20170120185209p:plain

ｺﾋﾟﾍﾟされたﾋﾞｭｰでは、こんな感じになってます。
f:id:kandennti:20170120185215p:plain

煩わしい原点合わせの操作が要らないんです。


念のためですが、3Dとﾘﾝｸしているﾃﾞｰﾀでは利用できません。
･･･必要ないでしょう。
又、2Dｺﾝﾎﾟｰﾈﾝﾄもｺﾋﾟﾍﾟ出来ません。事前に展開しておく必要が有ります。
こちらも全ての2Dｺﾝﾎﾟｰﾈﾝﾄを展開するﾏｸﾛをそのうちUpします。


追記
2Dｺﾝﾎﾟｰﾈﾝﾄを展開するﾏｸﾛは、こちらです。
2Dｺﾝﾎﾟｰﾈﾝﾄを展開する - C#ATIA