困惑するｵﾌｾｯﾄ平面を作成

ﾀｲﾄﾙだけでは伝わりにくいのですが、先日行った作業用対策のﾏｸﾛです。
（他人には役に立たないと思います）

結果的にはｵﾌｾｯﾄ平面を作成するだけなのですが、何といいますか面倒なんです。

赤色はXY平面、黄色はZX平面で紫色のBodyの面はZX平面と平行です。
紫色と同じ位置に、ZX平面からのｵﾌｾｯﾄ平面を作成したいのです。

手動で行うのであれば･･･ ” 平面からｵﾌｾｯﾄ " でZX平面を指定し
"ｵﾌｾｯﾄ" 部分のｺﾝﾃｷｽﾄﾒﾆｭｰで "2要素間を測定..." を選択。

ZX平面と紫色の面を測定し、ﾘﾝｸさせたくない為(あくまで数値だけ欲しい)
"測定を保持" のﾁｪｯｸを外してOKです。

更に、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

要は平らなﾎﾞﾃﾞｨ面を選択するだけで、先程手動操作で作成したｵﾌｾｯﾄ平面と
同等のものをｼﾞｬﾝｼﾞｬﾝ作成します。

先頭付近の定数

Private Const PRIORITY_ORIGINPLANE = True

と設定していると、基本平面(XY,YZ,ZX)と平行な平面の場合は勝手に
平面を作成・ﾘﾈｰﾑを行います。参照平面が
XY平面：Z + ｵﾌｾｯﾄ長さ
YZ平面：X + ｵﾌｾｯﾄ長さ
ZX平面：Y + ｵﾌｾｯﾄ長さ
の名称です。

基本平面と平行では無いBody面を指定した場合、Partファイル内に
存在する平面から平行な平面を探し出します。
平行な平面が1個しかない場合は、勝手に平面を作成し
参照平面名 + ｵﾌｾｯﾄ長さ
でﾘﾈｰﾑします。

緑色が面取りで、"平面.1" が面取りと平行な45°面です。
緑色の面を選択すると、他に平行な平面が存在しない為、
"平面.1+44.989mm" が作成されます。

平行な平面が複数存在している場合は、参照する平面を指定する
必要が有り、この様なﾀﾞｲｱﾛｸﾞが表示されます。

面がわかりやすいように、平行な平面は黄緑の太線表示に
切り替えます。（選択後は元に戻ります）

又、選択した面に平行な平面がPartファイル内に存在しない場合は

のﾀﾞｲｱﾛｸﾞが出現し、平面を作成することが出来ません。

他にもｲﾛｲﾛと問題もあるのですが、それ以上にそもそもこの平面に
価値があるものかどうかが疑問なんです。
この平面は、偶々ﾎﾞﾃﾞｨと同じ位置にある平面なので、当然ﾎﾞﾃﾞｨを
修正したら全く無関係の平面となってしまいます。
又、平面のｵﾌｾｯﾄ量を変更しても、平面をﾘﾈｰﾑする必要が有り
非常に手間です。
（それっぽい名前で無ければｵﾌｾｯﾄ量を調べますが、修正しﾘﾈｰﾑを
忘れた際は、誤った数値で捉えてしまう可能性があります）

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

ﾎﾞﾃﾞｨ毎にｺﾋﾟﾍﾟすることが大前提のﾙｰﾙなんですよね。ﾏｸﾛと同じで
ｺﾋﾟﾍﾟより関数化。CATIAにはﾊﾟﾜｰｺﾋﾟｰと言う素晴らしい機能が
あるのだから利用した方が良いですよ。
（同等の機能は他の3DCADにあるのかな？）