C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)

困惑するオフセット平面を作成

タイトルだけでは伝わりにくいのですが、先日行った作業用対策のマクロです。
(他人には役に立たないと思います)

結果的にはオフセット平面を作成するだけなのですが、何といいますか面倒なんです。
f:id:kandennti:20180914193019p:plain
赤色はXY平面、黄色はZX平面で紫色のBodyの面はZX平面と平行です。
紫色と同じ位置に、ZX平面からのオフセット平面を作成したいのです。

手動で行うのであれば・・・ ” 平面からオフセット " でZX平面を指定し
"オフセット" 部分のコンテキストメニューで "2要素間を測定..." を選択。
f:id:kandennti:20180914193027p:plain
ZX平面と紫色の面を測定し、リンクさせたくない為(あくまで数値だけ欲しい)
"測定を保持" のチェックを外してOKです。
f:id:kandennti:20180914193034p:plain
更に、ZX平面のプラス側だったため、"Y+28.296mm” とリネーム。
が、一番操作が速そうな気がしてます、が面倒なんです。

で、作ったのがこちらのマクロです。
想像以上に大規模になってしまいました・・・・。

'vba OffsetPlane_ver0.0.1  using-'KCL0.0.12'  by Kantoku
Option Explicit

'基準平面優先モード
'True-基準平面優先 False-優先無し
Private Const PRIORITY_ORIGINPLANE = True ' False

'作成したオフセット平面を入れる形状セット名
Private Const TARGET_HBBODY_NAME = "Planes"

Sub CATMain()
    'ドキュメントのチェック
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'モロモロ
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
    
    Dim pt As PART
    Set pt = doc.PART
    
    
    '平面リスト
    Dim planes As Collection
    Set planes = GetPlanes(doc)
    
    '選択
    Dim msg As String
    Dim refPlane As Plane
    
    Dim hbdy As HybridBody
    Set hbdy = Nothing
    
    Do
        '初期化
        Set refPlane = Nothing
        
        'ボディ面選択
        msg = "ボディ面を選択してください : ESCキー 終了"
        Dim face As AnyObject
        Set face = KCL.SelectItem(msg, "PlanarFace")
        
        If face Is Nothing Then Exit Do
        
        If Not IsBodyFace(face) Then
            msg = "対象はボディ面のみです!!"
            MsgBox msg, vbExclamation
        End If
        
        '基準平面と比較
        CATIA.HSOSynchronized = False
        
        If PRIORITY_ORIGINPLANE Then
            Set refPlane = GetParallelOriginPlane(pt, face)
        End If
        
        '全ての平面と比較
        If refPlane Is Nothing Then
            Set refPlane = GetParallelOtherPlane(pt, face, planes)
        End If
        
        '参照平面の指定無し
        If refPlane Is Nothing Then
            msg = "平行な平面が存在しない(又は指定していない)為、" & vbCrLf & _
                  "再度 面を指定して下さい"
            MsgBox msg, vbExclamation
            GoTo continue
        End If
        
        '平面作成
        Dim pln  As HybridShapePlaneOffset
        Set pln = InitPlane(pt, face, refPlane)
        If pln Is Nothing Then GoTo continue
        
        '形状セットへ
        If hbdy Is Nothing Then
            Set hbdy = GetHBBody(doc, TARGET_HBBODY_NAME)
        End If
        hbdy.AppendHybridShape pln
        
        '平面リストに追加
        planes.Add pln
        
        CATIA.HSOSynchronized = True
        
        MsgBox "平面を作成しました(" & pln.name & ")"
continue:
    Loop
    
    CATIA.HSOSynchronized = True
    
    MsgBox "Done"
End Sub

'ボディ面判断
Private Function IsBodyFace(ByVal face As AnyObject) As Boolean
    IsBodyFace = IIf(KCL.GetParent_Of_T(face, "Body") Is Nothing, _
                 False, True)
End Function

'形状セット取得・作成
Private Function GetHBBody(ByVal doc As PartDocument, _
                           ByVal hbdy_name As String) As HybridBody
    Dim sel As Selection
    Set sel = doc.Selection
    
    sel.Search "(Name='" & hbdy_name & "' & CATPrtSearch.OpenBodyFeature),all"
    
    If sel.Count2 > 0 Then
        Set GetHBBody = sel.Item2(1).Value
        Exit Function
    End If
    
    Dim pt As PART
    Set pt = doc.PART
    
    Dim hbdy As HybridBody
    Set hbdy = pt.hybridBodies.Add()
    hbdy.name = hbdy_name
    
    Set GetHBBody = hbdy
End Function

'平面情報なりにオフセット平面作成
Private Function InitPlane(ByVal pt As PART, ByVal face As PlanarFace, _
                           ByVal refpln As Plane) As HybridShapePlaneOffset
    Dim face_info As Variant
    face_info = GetPlaneInfo(pt, face)
    
    Dim refpln_info As Variant
    refpln_info = GetPlaneInfo(pt, refpln)
    
    Dim dist As Double
    dist = GetDistance(pt, face, refpln)
    
    Dim p2p_vec As Variant
    p2p_vec = ToVecter(face_info(0), refpln_info(0))
    
    Dim rev As Double
    rev = IIf(Dot(refpln_info(1), p2p_vec) < 0, 1, -1)
    
    Dim pln
    Set pln = InitPlaneOffset(pt, refpln, dist * rev)
    
    Set InitPlane = pln
End Function

'PlaneOffset
Private Function InitPlaneOffset(ByVal pt As PART, ByVal ref As Reference, _
                                 ByVal dist As Double) As HybridShapePlaneOffset
    Dim fact As HybridShapeFactory
    Set fact = pt.HybridShapeFactory
    
    Dim pln As HybridShapePlaneOffset
    Set pln = fact.AddNewPlaneOffset(ref, dist, False)
    pln.name = GetPlaneNewName(ref, Round(dist, 3))
    pt.UpdateObject pln
    
    Set InitPlaneOffset = pln
End Function

'それっぽい名前取得
Private Function GetPlaneNewName(ByVal ref As Reference, ByVal dist As Double) As String
    Dim txt As String
    
    Select Case KCL.GetInternalName(ref)
        Case "xy-plane"
            txt = "Z"
        Case "yz-plane"
            txt = "X"
        Case "zx-plane"
            txt = "Y"
        Case Else
            txt = ref.name
    End Select
    
    If dist < 0 Then
        txt = txt & CStr(dist) & "mm"
    Else
        txt = txt & "+" & CStr(dist) & "mm"
    End If
    
    GetPlaneNewName = txt
End Function

'指定平面と平行なものを取得
Private Function GetParallelOtherPlane(ByVal pt As PART, _
                                       ByVal face As AnyObject, _
                                       ByVal planes As Collection) As Plane
    Set GetParallelOtherPlane = Nothing
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim pln As Plane
    For Each pln In planes
        If IsParallel(pt, face, pln) Then
            lst.Add pln
        End If
    Next
    
    Dim msg As String
    Select Case lst.count
        Case Is < 1
            '平行平面無し
        Case 1
            Set GetParallelOtherPlane = lst(1)
        Case Else
            msg = "指定面と平行な平面が複数存在します。" & vbCrLf & _
                  "参照する面を指定して下さい"
            MsgBox msg, vbInformation
            '再度選択
            Set GetParallelOtherPlane = SelectRefPlane(pt, face, lst)
    End Select
    
End Function

'参照平面選択
Private Function SelectRefPlane(ByVal pt As PART, _
                                ByVal face As AnyObject, _
                                ByVal planes As Collection) As Plane
    Set SelectRefPlane = Nothing
    
    'グラフィックバックアップ
    Dim infos As Variant
    infos = GetGraphicsInfoList(planes)
    
    '候補平面のグラフィック変更
    Call SetGraphicsInfoList(infos, Array(0, 0, 255, 0, 3, 0))
    
    '選択
    Dim refpln As Plane
    Dim msg As String
    Do
        '初期化
        Set refpln = Nothing
        
        '平面選択
        msg = "参照する平面を選択してください : ESCキー 終了"
        Set refpln = KCL.SelectItem(msg, "Plane")
        If refpln Is Nothing Then Exit Do
        
        '平行OK
        If IsParallel(pt, face, refpln) Then Exit Do
        
        '繰り返し
        msg = "平行な平面を選択してください!"
        MsgBox msg, vbExclamation
    Loop
    
    'グラフィック戻し
    Call SetGraphicsInfoList(infos)
    
    Set SelectRefPlane = refpln
End Function


'コレクション内平面名の文字列化
Private Function GetPlanesName(ByVal plns As Collection) As String
    Dim ary() As Variant
    ReDim ary(plns.count - 1)
    
    Dim i As Long
    For i = 0 To plns.count - 1
        ary(i) = plns(i + 1).name
    Next
    
    GetPlanesName = Join(ary, vbCrLf)
End Function


'----- 平面関連 -----
'平行?
Private Function IsParallel(ByVal pt As PART, ByVal p1, ByVal p2) As Boolean
    IsParallel = IIf(GetAngle(pt, p1, p2) < 0.001, True, False)
End Function

'平面情報
'return 0-Origin 1-Direction As Plane
Private Function GetPlaneInfo(ByVal pt As PART, ByVal pln) As Variant
    Dim pln_vari As Variant
    Set pln_vari = pln
    
    Dim info(1) As Variant
    
    Dim ori(2)
    pln_vari.GetOrigin ori
    info(0) = ori
    
    info(1) = GetPlaneDirection(pln_vari)
    GetPlaneInfo = info
End Function

'平面法線
Private Function GetPlaneDirection(ByVal pln_vari As Variant) As Variant
    Dim vec1(2)
    pln_vari.GetFirstAxis vec1
    
    Dim vec2(2)
    pln_vari.GetSecondAxis vec2
    
    GetPlaneDirection = Cross(vec1, vec2)
End Function

'平面全て取得
Private Function GetPlanes(ByVal doc As Document) As Collection
    Dim lst As Collection
    Set lst = New Collection
    Set GetPlanes = lst
    
    Dim sel As Selection
    Set sel = doc.Selection
    
    CATIA.HSOSynchronized = False
    
    sel.Search "CATPrtSearch.Plane,all"
    
    If sel.Count2 < 1 Then Exit Function
    
    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item2(i).Value
    Next
    sel.Clear
    
    CATIA.HSOSynchronized = True
End Function

'平行な基本平面を取得
Private Function GetParallelOriginPlane(ByVal pt As PART, _
                                        ByVal face As AnyObject) As Plane
    Set GetParallelOriginPlane = Nothing
    
    With pt.OriginElements
        Select Case True
            Case IsParallel(pt, face, .PlaneXY)
                Set GetParallelOriginPlane = .PlaneXY
            Case IsParallel(pt, face, .PlaneYZ)
                Set GetParallelOriginPlane = .PlaneYZ
            Case IsParallel(pt, face, .PlaneZX)
                Set GetParallelOriginPlane = .PlaneZX
        End Select
    End With
End Function


'----- 測定関連 -----
'Measurable
Private Function GetMeasurable(ByVal pt As PART, ByVal p1) 'As Measurable
    Dim wb, meas As Measurable
    Set wb = pt.Parent.GetWorkbench("SPAWorkbench")
    Set GetMeasurable = wb.GetMeasurable(p1)
End Function

'角度
Private Function GetAngle(ByVal pt As PART, ByVal p1, ByVal p2) As Double
    Dim meas As Measurable
    Set meas = GetMeasurable(pt, p1)
    
    GetAngle = meas.GetAngleBetween(p2)
End Function

'距離
Private Function GetDistance(ByVal pt As PART, ByVal p1, ByVal p2) As Variant
    Dim meas As Measurable
    Set meas = GetMeasurable(pt, p1)
    
    GetDistance = meas.GetMinimumDistance(p2)
End Function


'----- グラフィック関連 -----
'グラフィック情報取得
'0-show , 1-Color R , 2-ColorG , 3-ColorB , 4-Width , 5-Pick
Private Function GetGraphicsInfo(ByVal itm As AnyObject) As Variant
    Dim doc As Document
    Set doc = KCL.GetParent_Of_T(itm, "PartDocument")
    
    Dim sel As Selection
    Set sel = doc.Selection
    
    sel.Clear
    sel.Add itm
    
    Dim info(5) As Variant
    Dim vis As Variant 'VisPropertySet
    Set vis = sel.VisProperties
    
    vis.GetShow info(0)
    vis.GetRealColor info(1), info(2), info(3)
    vis.GetVisibleWidth info(4)
    vis.GetPick info(5)
    
    sel.Clear
    GetGraphicsInfo = info
End Function

'グラフィック情報設定
'0-show , 1-Color R , 2-ColorG , 3-ColorB , 4-Width , 5-Pick
Private Sub SetGraphicsInfo(ByVal itm As AnyObject, ByVal info As Variant)
    Dim doc As Document
    Set doc = KCL.GetParent_Of_T(itm, "PartDocument")
    
    Dim sel As Selection
    Set sel = doc.Selection
    
    sel.Clear
    sel.Add itm
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    vis.SetShow info(0)
    vis.SetRealColor info(1), info(2), info(3), 1
    vis.SetVisibleWidth info(4), 1
    vis.SetPick info(5)
    
    sel.Clear
End Sub

'リスト内グラフィック情報取得
Private Function GetGraphicsInfoList(ByVal plns As Collection) As Variant
    Dim ary() As Variant
    ReDim ary(plns.count - 1)
    
    Dim i As Long
    For i = 0 To plns.count - 1
        ary(i) = Array(plns(i + 1), GetGraphicsInfo(plns(i + 1)))
    Next
    GetGraphicsInfoList = ary
End Function

'リスト内グラフィック情報設定
'Optional allinfo 指定時は全てその設定
Private Sub SetGraphicsInfoList(ByVal graps As Variant, _
                                Optional ByVal allinfo = Empty)
    Dim i As Long
    
    If IsEmpty(allinfo) Then
        For i = 0 To UBound(graps)
            Call SetGraphicsInfo(graps(i)(0), graps(i)(1))
        Next
    Else
        For i = 0 To UBound(graps)
            Call SetGraphicsInfo(graps(i)(0), allinfo)
        Next
    End If
End Sub


'----- ベクトル関連 -----
'内積3D
Private Function Dot(ByVal v1 As Variant, ByVal v2 As Variant) As Double
    Dot = v1(0) * v2(0) + v1(1) * v2(1) + v1(2) * v2(2)
End Function

'外積3D
Private Function Cross(ByVal v1 As Variant, ByVal v2 As Variant) As Variant
    Dim vec(2) As Double
    vec(0) = v1(1) * v2(2) - v1(2) * v2(1)
    vec(1) = v1(2) * v2(0) - v1(0) * v2(2)
    vec(2) = v1(0) * v2(1) - v1(1) * v2(0)
    Cross = vec
End Function

'2点間ベクトル
Private Function ToVecter(ByVal p1 As Variant, ByVal p2 As Variant) As Variant
    Dim vec(2) As Double, i As Long
    For i = 0 To UBound(vec)
        vec(i) = p2(i) - p1(i)
    Next
    ToVecter = vec
End Function

要は平らなボディ面を選択するだけで、先程手動操作で作成したオフセット平面と
同等のものをジャンジャン作成します。
f:id:kandennti:20180914193053p:plain
先頭付近の定数

Private Const PRIORITY_ORIGINPLANE = True

と設定していると、基本平面(XY,YZ,ZX)と平行な平面の場合は勝手に
平面を作成・リネームを行います。参照平面が
XY平面:Z + オフセット長さ
YZ平面:X + オフセット長さ
ZX平面:Y + オフセット長さ
の名称です。

基本平面と平行では無いBody面を指定した場合、Partファイル内に
存在する平面から平行な平面を探し出します。
平行な平面が1個しかない場合は、勝手に平面を作成し
参照平面名 + オフセット長さ
でリネームします。
f:id:kandennti:20180914193103p:plain
緑色が面取りで、"平面.1" が面取りと平行な45°面です。
緑色の面を選択すると、他に平行な平面が存在しない為、
"平面.1+44.989mm" が作成されます。

平行な平面が複数存在している場合は、参照する平面を指定する
必要が有り、この様なダイアログが表示されます。
f:id:kandennti:20180914193109p:plain
面がわかりやすいように、平行な平面は黄緑の太線表示に
切り替えます。(選択後は元に戻ります)
f:id:kandennti:20180914193115p:plain

又、選択した面に平行な平面がPartファイル内に存在しない場合は
f:id:kandennti:20180914193122p:plain
のダイアログが出現し、平面を作成することが出来ません。


他にもイロイロと問題もあるのですが、それ以上にそもそもこの平面に
価値があるものかどうかが疑問なんです。
この平面は、偶々ボディと同じ位置にある平面なので、当然ボディを
修正したら全く無関係の平面となってしまいます。
又、平面のオフセット量を変更しても、平面をリネームする必要が有り
非常に手間です。
(それっぽい名前で無ければオフセット量を調べますが、修正しリネームを
忘れた際は、誤った数値で捉えてしまう可能性があります)

一ヶ所の変更で、他の部分が変更されないようなモデリングルールにする
気持ちもわからなくは無いのですが、修正した際は関連する部分も
連携しているような作り方にしておかないと、手間ばかりで
「2D設計から3D設計に切り替えたが、効果が上がらず むしろ
工数が増えるばかり」の典型例に感じてしょうがないんですよ。

ボディ毎にコピペすることが大前提のルールなんですよね。マクロと同じで
コピペより関数化。CATIAにはパワーコピーと言う素晴らしい機能が
あるのだから利用した方が良いですよ。
(同等の機能は他の3DCADにあるのかな?)

GetDirectionが上手く行かない2

こちらの続きです。
GetDirectionが上手く行かない - C#ATIA

imihitoさんからのアドバイスを頂き、こんな風にしてみました。
(これだけじゃ動きません)

'vba
'平面法線
Private Function GetPlaneDirection(ByVal pln As Plane) As Variant
    Dim pln_vari As Variant
    Set pln_vari = pln
    
    Dim vec1(2)
    pln_vari.GetFirstAxis vec1
    
    Dim vec2(2)
    pln_vari.GetSecondAxis vec2
    
    GetPlaneDirection = Cross(vec1, vec2)
End Function

'外積3D
Private Function Cross(ByVal v1 As Variant, ByVal v2 As Variant) As Variant
    Dim vec(2) As Double
    vec(0) = v1(1) * v2(2) - v1(2) * v2(1)
    vec(1) = v1(2) * v2(0) - v1(0) * v2(2)
    vec(2) = v1(0) * v2(1) - v1(1) * v2(0)
    Cross = vec
End Function

外積の関数、持ってました・・・。
GetPlaneDirectionにPlane型を投げると、x,y,zのVariant型(中身はDouble)の配列を
返します。

・・・そういえば、何処かで新入社員教育で ”ダブル型の変数を用意して下さい”
と指示したら

Dim W

と書かれた。 と言うネタを思い出しました。(意味は無いです)

GetDirectionが上手く行かない

平面の向きを取得したいだけなのですが、SPAWorkbenchのGetDirectionが
エラーになり上手く行かないです。 確かに使った事無いんですが・・・。

'vba これは一部なのでこれだけじゃ動かないです

'平面情報
'return 0-Distance 1-p1_Direction 2-p2_Direction
Private Function GetPlaneInfo(ByVal pt As PART, ByVal p1, ByVal p2) As Variant
    Dim meas 'As Measurable
    Set meas = GetMeasurable(pt, p1)
    
    Dim info(2) As Variant
    info(0) = meas.GetMinimumDistance(p2)
    
    Dim vec(2) 'As Variant
    meas.GetDirection vec 'ここでエラー
    info(1) = vec
    
    Set meas = GetMeasurable(pt, p2)
    meas.GetDirection vec
    info(2) = vec
    
    GetPlaneInfo = info
End Function

Private Function GetMeasurable(ByVal pt As PART, ByVal p1) 'As Measurable
    Dim wb, meas As Measurable
    Set wb = pt.Parent.GetWorkbench("SPAWorkbench")
    Set GetMeasurable = wb.GetMeasurable(p1)
End Function

この手は型指定するとエラーになるのはわかっているので、型指定無しです。

代案が無くも無いのですが、面倒なので直接平面の向きを取得したいのですが・・・。

参照かつ外部とのスケッチ拘束を削除する

自分が作業して欲しくなったので突貫で作りました。

こんなスケッチ1を作ります。
f:id:kandennti:20180905155613p:plain
続いて、こんなスケッチ2を作ります。
f:id:kandennti:20180905155620p:plain
基本的にスケッチ1が変更されても、スケッチ2の形状は影響は有りません。
但し、"オフセット.20" はスケッチ1に対して参照の拘束が付いています。
まぁクリアランスを確認したい とかです。

ここで問題になるのは、スケッチ1が削除される場合です。
こんな風になりますよね?
f:id:kandennti:20180905155627p:plain
”すべての子を削除” のチェックを外し、実行してしまうと
f:id:kandennti:20180905155633p:plain
まぁエラーになります。形状には影響無いので無視したいところ
なのですが。

要は
・参照の拘束
・外部との拘束
と言うことです。

で、この様なスケッチ拘束を削除するマクロです。

'vba Part_RemoveExternalElmConst Ver0.0.1  using-'KCL0.0.12'  by Kantoku

Option Explicit

Private Const EXTERNAL_ELEMENT_NAME = "CATIAGeometry"

Sub CATMain()

    'ドキュメントのチェック
    If Not CanExecute(Array("PartDocument")) Then Exit Sub

    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    'スケッチ取得
    Dim skts As Collection
    Set skts = GetSketchList(doc)
    If skts.count < 1 Then
        MsgBox "スケッチがありません!", vbExclamation
        Exit Sub
    End If
    
    '処理確認
    Dim msg As String
    msg = "個のスケッチに対して処理します。宜しいですか?"
    If MsgBox(skts.count & msg, vbYesNo + vbQuestion) = vbNo Then Exit Sub
    
    '削除対象の拘束取得
    Dim del_lst As Collection
    Set del_lst = GetRemoveConstraintList(skts)
    
    If del_lst.count < 1 Then
        MsgBox "削除すべきスケッチ拘束が有りません!", vbExclamation
        Exit Sub
    End If
    
    '削除
    Dim cnt As Long
    cnt = RemoveConstraint(del_lst)
    
    'done
    doc.Part.Update
    MsgBox cnt & "個のスケッチ拘束を削除しました"

End Sub

'リスト内拘束の削除
Private Function RemoveConstraint(ByVal cons As Collection) As Long
    RemoveConstraint = cons.count
    
    Dim sel As Selection
    Set sel = KCL.GetParent_Of_T(cons(1), "PartDocument").Selection
    
    CATIA.HSOSynchronized = False
    
    sel.Clear
    
    Dim con As Constraint
    For Each con In cons
        sel.Add con
    Next
    sel.Delete
    sel.Clear
    
    CATIA.HSOSynchronized = True
End Function

'削除対象拘束リスト
'条件:参照チェックON & 外部要素との拘束
Private Function GetRemoveConstraintList(ByVal skts As Collection) As Collection
    Dim lst As Collection
    Set lst = New Collection
    
    Dim skt As Sketch
    Dim con As Constraint
    For Each skt In skts
        For Each con In skt.Constraints
            Debug.Print con.Name & " : " & CStr(con.Mode)
            If con.Mode = catCstModeDrivingDimension Then GoTo continue
            If Not HasExternalElementConstraint(con) Then GoTo continue
            
            lst.Add con
continue:
        Next
    Next
    
    Set GetRemoveConstraintList = lst
End Function

'ドキュメント内のスケッチリスト
Private Function GetSketchList(ByVal doc As Document) As Collection
    Dim sel As Selection
    Set sel = doc.Selection
    
    CATIA.HSOSynchronized = False
    With sel
        .Clear
        .Search "CATPrtSearch.Sketch,all"
    End With
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item2(i).Value
    Next
    
    sel.Clear
    CATIA.HSOSynchronized = True
    
    Set GetSketchList = lst
End Function

'自身のスケッチ要素以外との拘束か?
Private Function HasExternalElementConstraint(ByVal con As Constraint) As Boolean
    HasExternalElementConstraint = True
    
    Dim elm As AnyObject
    Dim idx As Long
    idx = 0
    
    On Error Resume Next
    
    Do While Err.Number = 0
        Err.Number = 0
        idx = idx + 1
        Set elm = con.GetConstraintElement(idx)
        If InStr(elm.Name, EXTERNAL_ELEMENT_NAME) > 0 Then
            Exit Function
            
        End If
    Loop
    HasExternalElementConstraint = False
End Function

同一スケッチ内の参照拘束は、確認の意味もあるだろうと思う為、削除しません。
(残っていても、ダメージは少ないだろうと思ってます)

最近は細々したものばかり・・・。

スケッチの拘束の参照を切り替える

少し前に作成したこちらのマクロ、使いにくくてしょうがない。
クリックしたスケッチ点にHVの拘束を付ける - C#ATIA
何処かに、拘束が重複しないように整えてくれるマクロ、落ちてないでしょうか?
(標準な機能では無いですよね?)

非常に下らないのですが、スケッチの拘束の参照のON OFFを切り替える
マクロを作ってみました。
f:id:kandennti:20180830183944p:plain
最近、この操作を頻繁に行って疲れてきたので。
(そもそもそんな拘束を作りたくないのですが、ルール上仕方なく・・・)

こんなコードです。

'vba スケッチ オフセット拘束 モード切り替えテスト
Sub CATMain()
    'ワークベンチチェック
    If Not CATIA.GetWorkbenchId = "CS0WKS" Then
        MsgBox "スケッチ作業中のみ使用できます"
        Exit Sub
    End If
    
    
    '選択準備
    Dim sel As Variant ' Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim filter As Variant
    filter = Array("Constraint")
    
    Dim msg As String
    msg = "拘束を選択 / ESC=キャンセル"
    
    '選択
    Do
        sel.Clear
        Select Case sel.SelectElement2(filter, msg, False)
            Case "Cancel", "Undo", "Redo"
                Exit Sub
        End Select
        Call ChangeMode(sel.Item(1).value)
    Loop
End Sub

'拘束モード切り替え
Private Sub ChangeMode(ByVal con As Constraint)
    con.Mode = IIf(con.Mode = catCstModeDrivenDimension, _
                   catCstModeDrivingDimension, _
                   catCstModeDrivenDimension)
End Sub

通常の場合であれば、これだけで十分機能するのですが、
問題は通常じゃない時です。

例えば、こんな状態です。(普段は拘束名は表示しないのです。邪魔なので。)
f:id:kandennti:20180830184000p:plain
過剰拘束の状態なのですが、オフセット7,8,12の何れかを参照にすれば
解消されますよね。

上記のマクロでオフセット7を選択すると
f:id:kandennti:20180830184007p:plain
消えたのではなく、黒くなって見えにくくなっちゃいます。

一度スケッチャーから抜け、再度入ると正しく表示してくれます。
f:id:kandennti:20180830184016p:plain

スケッチ解析を見てみると
f:id:kandennti:20180830184028p:plain
クリックしたオフセット7が "不明" なのは理解できますが、
過剰拘束が解消したオフセット8,12は問題無いのですが、黒いんです。
そもそも黒い拘束は何を意味しているのでしょうか??

Helpのスケッチャーの "色の使用" を見ても黒色の説明が無さそう・・・。
(そもそも黒なのか?)
何となくUpdate待ちのような気がしたので、Updateさせることに
しました。

'拘束モード切り替え
Private Sub ChangeMode(ByVal con As Constraint)
    con.Mode = IIf(con.Mode = catCstModeDrivenDimension, _
                   catCstModeDrivingDimension, _
                   catCstModeDrivenDimension)
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(con, "Part")
    
    Call pt.UpdateObject(con)
End Sub

結論から書くと、これでは問題の解消にはなりませんでした。

    'Call pt.UpdateObject(con)
    Call pt.Update

こうすると上手く出来るのですが(何故か最初は失敗する事が多い)、
作業しているスケッチより、PartのTreeの上部でエラーが出ている場合、
上手く行かないような気がするので、単純なUpdateはしたくないのが
本音です。

仕方が無いので、作業中のスケッチをUpdateすることにしました。

'拘束モード切り替え
Private Sub ChangeMode(ByVal con As Constraint)
    con.Mode = IIf(con.Mode = catCstModeDrivenDimension, _
                   catCstModeDrivingDimension, _
                   catCstModeDrivenDimension)
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(con, "Part")
    
    Dim skt As Sketch
    Set skt = KCL.GetParent_Of_T(con, "Sketch")
    
    Call pt.UpdateObject(skt)
End Sub

これも最初に失敗する事があるのですが、比較的安定して正しく表示
されるようになりました。
f:id:kandennti:20180830184042p:plain

一応、CATIA.RefreshDisplay の切り替えのみをテストしましたが、
効果がないです。 それを考えると表示だけの問題では無さそうです。
(そもそもこんな拘束を作りたくない・・・)

クリックしたスケッチ点にHVの拘束を付ける

何となく、近い将来必要に迫られる気がしたので、作りました。
スケッチャーWB時のみ、クリックしたスケッチの点に原点からHとVの
拘束を付けます。

'vba 選択したスケッチの点にHVの拘束を作成  using-'KCL0.0.12'

Sub CATMain()
    'ワークベンチチェック
    If Not CATIA.GetWorkbenchId = "CS0WKS" Then
        MsgBox "スケッチ作業中のみ使用できます"
        Exit Sub
    End If
    
    'モロモロ取得
    Dim skt As Sketch
    Set skt = GetActiveSketch()
    
    Dim ax2d As Axis2D
    Set ax2d = skt.AbsoluteAxis
    
    Dim cons As Constraints
    Set cons = skt.Constraints
    
    Dim pt As Part
    Set pt = KCL.GetParent_Of_T(skt, "PartDocument").Part
    
    Dim refH As Reference
    Set refH = pt.CreateReferenceFromObject(ax2d.HorizontalReference)
    
    Dim refV As Reference
    Set refV = pt.CreateReferenceFromObject(ax2d.VerticalReference)
    
    '選択準備
    Dim sel As Variant ' Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim filter As Variant
    filter = Array("Point2D")
    
    Dim msg As String
    msg = "点を選択 / ESC=キャンセル"

    Dim refP As Reference
    
    '選択
    Do
        sel.Clear
        Select Case sel.SelectElement2(filter, msg, False)
            Case "Cancel", "Undo", "Redo"
                Exit Sub
        End Select
        Set refP = sel.Item(1).Reference
        Call InitConstraint(refP, refH, refV, cons)
    Loop
End Sub

'拘束作成
Private Sub InitConstraint(ByVal refP As Reference, _
                           ByVal refH As Reference, _
                           ByVal refV As Reference, _
                           ByVal cons As Constraints)
    Dim con(1) As Constraint
    With cons
        Set con(0) = .AddBiEltCst(catCstTypeDistance, refH, refP)
        Set con(1) = .AddBiEltCst(catCstTypeDistance, refV, refP)
    End With
    
    Dim i As Long
    For i = 0 To UBound(con)
        If Not con(i).Status = catCstStatusOK Then
            Call RemoveConstraint(con(i))
        End If
    Next
End Sub

'拘束削除
Private Sub RemoveConstraint(ByVal con As Constraint)
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    With sel
        .Clear
        .Add con
        .Delete
    End With
End Sub

'アクティブなスケッチ取得
Private Function GetActiveSketch() As Sketch
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim skt As Sketch
    
    With sel
        Call .Clear
        Call .Search("CATPrtSearch.Sketch,in")
        Set skt = .Item(1).value
        Call .Clear
    End With
    Set GetActiveSketch = skt
End Function

突貫で作ったのでちょっと雑です。

スケッチの点は "自動寸法拘束" が付かないんですよね。
f:id:kandennti:20180821192025p:plain
付かなくて正解なんですけど。(恐らく邪魔)

過拘束も新たに作成しようとしている分はチェックしています。

方向反転判断しながら平行曲線作成

"GSDのサポートを指定した平行曲線マクロが上手く行かない" とご相談頂きました。
こんな感じでしょうか?
f:id:kandennti:20180808185054p:plain

まず、実際にマクロの記録を取ってみます。

'catvba
Sub CATMain()

Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument

Dim part1 As Part
Set part1 = partDocument1.Part

Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory

Dim hybridBodies1 As hybridBodies
Set hybridBodies1 = part1.hybridBodies

Dim hybridBody1 As HybridBody
Set hybridBody1 = hybridBodies1.Item("形状セット.1")

Dim hybridShapes1 As HybridShapes
Set hybridShapes1 = hybridBody1.HybridShapes

Dim hybridShapeExtract1 As HybridShapeExtract
Set hybridShapeExtract1 = hybridShapes1.Item("抽出.1")

Dim reference1 As Reference
Set reference1 = part1.CreateReferenceFromBRepName("BorderREdge:(BEdge:(Brp:(FeatureRSUR.1;(Brp:(Pad.1;0:(Brp:(Sketch.1;3)));Brp:(Pad.1;2)));None:(Limits1:();Limits2:();-1);Cf11:());WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)", hybridShapeExtract1)

Dim reference2 As Reference
Set reference2 = part1.CreateReferenceFromObject(hybridShapeExtract1)

Dim hybridShapeCurvePar1 As HybridShapeCurvePar
Set hybridShapeCurvePar1 = hybridShapeFactory1.AddNewCurvePar(reference1, reference2, 7#, False, False)

hybridShapeCurvePar1.SmoothingType = 0

hybridBody1.AppendHybridShape hybridShapeCurvePar1

part1.InWorkObject = hybridShapeCurvePar1

part1.Update

End Sub

細かくチェックしているのが面倒な為、個人的には記録をとったマクロを再実行します。
同様の結果になれば、全て記録されている目安になります。

これ全てが欲しい訳ではなく、実際に欲しい部分は、こちらの3行です。

Dim hybridShapeCurvePar1 As HybridShapeCurvePar
Set hybridShapeCurvePar1 = hybridShapeFactory1.AddNewCurvePar(reference1, reference2, 7#, False, False)

hybridShapeCurvePar1.SmoothingType = 0

個人的には問題を切り分けたい為、この平行曲線を作成するだけの関数を作成します。

Private Function InitCurvePar(xxxx) As HybridShapeCurvePar
    Dim hybridShapeCurvePar1 As HybridShapeCurvePar
    Set hybridShapeCurvePar1 = hybridShapeFactory1.AddNewCurvePar(reference1, reference2, 7#, False, False)
    
    hybridShapeCurvePar1.SmoothingType = 0
    
    Set InitCurvePar = hybridShapeCurvePar1
End Function

出来上がった平行曲線のリファレンスを取得し戻り値とするのも方法ですが、とりあえず
オブジェクトそのものを返すことにしました。
xxxx部分は必要となる引数です。必要となるものは "Set hybridShapeCurvePar1~"
の行に比較的有ります。
・hybridShapeFactory1
・reference1
・reference2
・7#(距離)
この辺でしょうか。

これらを引数としますが、"reference1" の名称ではあまりにも意味がわかりにくいため
それなりの名称に変更します。

Private Function InitCurvePar(ByVal part1 As Part, _
                              ByVal edgeRef As Reference, _
                              ByVal supportRef As Reference, _
                              ByVal leng As Double) As HybridShapeCurvePar
    Dim hybridShapeFactory1 As HybridShapeFactory
    Set hybridShapeFactory1 = part1.HybridShapeFactory

    Dim hybridShapeCurvePar1 As HybridShapeCurvePar
    Set hybridShapeCurvePar1 = hybridShapeFactory1.AddNewCurvePar(edgeRef, supportRef, leng, False, False)
    
    hybridShapeCurvePar1.SmoothingType = 0
    
    part1.UpdateObject hybridShapeCurvePar1
    
    Set InitCurvePar = hybridShapeCurvePar1
End Function

マクロの記録をとった場合は、"part1.Update" で記録されますが、
"part1.UpdateObject" の方が処理も軽いですし、他のエラーの影響も受けません。
(手動のローカル更新と同等です)

質問者さんが悩まれているのは、ここからです。
実際はオフセット方向がサポート上にならない場合があります。
そのような場合、手動であれば "方向を反転" を押す事になりますよね?
f:id:kandennti:20180808185111p:plain

HybridShapeCurveParオブジェクトを調べてみると、それっぽいプロパティが有ります。
f:id:kandennti:20180808185122p:plain

英語わからないのですが、それっぽい事には気が付きます。

これを "On Error Resume Next" を利用しながら判断し処理するように
書き換えました。

Private Function InitCurvePar(ByVal part1 As Part, _
                              ByVal edgeRef As Reference, _
                              ByVal supportRef As Reference, _
                              ByVal leng As Double) As HybridShapeCurvePar
    Dim hybridShapeFactory1 As HybridShapeFactory
    Set hybridShapeFactory1 = part1.HybridShapeFactory

    Dim hybridShapeCurvePar1 As HybridShapeCurvePar
    Set hybridShapeCurvePar1 = hybridShapeFactory1.AddNewCurvePar(edgeRef, supportRef, leng, False, False)
    
    hybridShapeCurvePar1.SmoothingType = 0
    
    On Error Resume Next
        err.Number = 0
        part1.UpdateObject hybridShapeCurvePar1
        
        '反転
        If Not err.Number = 0 Then
            err.Number = 0
            hybridShapeCurvePar1.InvertDirection = True
            part1.UpdateObject hybridShapeCurvePar1
        End If
        
        '反転してもエラーの為、そもそも無理
        If Not err.Number = 0 Then
             Set hybridShapeCurvePar1 = Nothing
        End If
    On Error GoTo 0
    
    Set InitCurvePar = hybridShapeCurvePar1
End Function

同じ事を複数書いたりしてますが、わかりやすくする為にこのようにしました。
(個人的にはもっと書き直したいです)


この自作関数を呼び出す為に、最初に記録したマクロをこんな感じで
書き換えます。

    ・・・

    Dim hybridShapeCurvePar1 As HybridShapeCurvePar
    'Set hybridShapeCurvePar1 = hybridShapeFactory1.AddNewCurvePar(reference1, reference2, 7#, False, False)
    
    'hybridShapeCurvePar1.SmoothingType = 0
    
    '自作関数処理
    Set hybridShapeCurvePar1 = InitCurvePar(part1, reference1, reference2, 7#)
    
    '両側失敗
    If hybridShapeCurvePar1 Is Nothing Then
        MsgBox "オフセット距離が思わしく有りません!"
        Exit Sub
    End If
    
    hybridBody1.AppendHybridShape hybridShapeCurvePar1
    
    part1.InWorkObject = hybridShapeCurvePar1
    
    part1.Update

End Sub

InitCurveParの4番目の引数を "-7#" "1000#" 等試して頂ければ、それなりの
処理をしてくれます。

変数名もイマイチなのですが、とりあえず僕が進める手順はこの様な感じです。