今更ながら、ﾎﾞﾃﾞｨからMinimumBoxを作成する(Sketch＆Pad)

少し前にMinimumBoxで検索された方がいらっしゃったので
ﾏｸﾛ版として作ってみました。
"Unofficial CATIA User Forum" でここなさんがﾊﾟﾜｰｺﾋﾟｰの
ｻﾝﾌﾟﾙとしてUpされていましたし、確かy4yamaさんがﾏｸﾛ版として
Upしていました。(中身は見なかったです･･･)

折角作るのであれば、"その頃のものと違いのあるものを" と思い
ｽｹｯﾁ + ﾊﾟｯﾄﾞで作られるようにしています。
(あの頃のものは恐らく、ｻｰﾌｪｽ + 厚みｻｰﾌｪｽだと思います。)

処理が大した事無いのに、相変わらず大げさなｺｰﾄﾞはこちらです。

'vba GetMinimumBox
Option Explicit
Private Const MacroName = "GetMinimumBox"
Private Const DmyLng = 1000000# 'ﾀﾞﾐｰ面距離
Private Enum MinMax '測定値配列ｲﾝﾃﾞｯｸｽ用
    MinX = 0
    MaxX = 1
    MinY = 2
    MaxY = 3
    MinZ = 4
    MaxZ = 5
End Enum

Sub CATMain()
    '初期設定
    '測定方向用ﾍﾞｸﾄﾙ　ｲﾝﾃﾞｯｸｽはEnum MinMax
    Dim Vec As Variant
    Vec = Array(Array(-1#, 0#, 0#), Array(1#, 0#, 0#), Array(0#, -1#, 0#), _
                Array(0#, 1#, 0#), Array(0#, 0#, -1#), Array(0#, 0#, 1#))
    Dim Msg$
        
    'PartDocumentﾁｪｯｸ
    If Not TypeName(CATIA.ActiveDocument) = "PartDocument" Then
        Msg = "Partﾌｧｲﾙをｱｸﾃｨﾌﾞにして下さい!"
        MsgBox Msg, vbOKOnly + vbCritical, MacroName
        Exit Sub
    End If
    Dim Actdoc As PartDocument: Set Actdoc = CATIA.ActiveDocument
    
    'ﾎﾞﾃﾞｨの選択
    Dim SelFilter  As Variant: SelFilter = Array("BiDim")
    Dim TargetBody As AnyObject
    Msg = "対象のﾎﾞﾃﾞｨを選択して下さい : [Esc]=ｷｬﾝｾﾙ"
    Set TargetBody = SelectBody(Msg, SelFilter, Actdoc)
    If IsNothing(TargetBody) Then
        Msg = "中止します"
        MsgBox Msg, vbOKOnly + vbExclamation, MacroName
        Exit Sub
    End If
    
    '指定ﾎﾞﾃﾞｨのﾊﾟｰﾄを取得
    Dim WorkPart As Part: Set WorkPart = GetParent_Of_T(TargetBody, "Part")
    If IsNothing(WorkPart) Then
        Msg = "指定ﾎﾞﾃﾞｨからﾊﾟｰﾄが取得できない為、中止します"
        MsgBox Msg, vbOKOnly + vbCritical, MacroName
        Exit Sub
    End If
    
    '座標系選択
    SelFilter = Array("AxisSystem")
    Dim Ax As AxisSystem
    Do
        Msg = "取得する方向の座標系を選択して下さい" + _
              "[Esc]=ｷｬﾝｾﾙ 又は 絶対座標"
        Set Ax = SelectItem(Msg, SelFilter, Actdoc)
        If IsNothing(Ax) Then
            Msg = "絶対座標系で取得しますか?" + vbNewLine + _
                  "「はい」- 絶対座標" + vbNewLine + _
                  "「いいえ」- ｷｬﾝｾﾙ"
            If MsgBox(Msg, vbYesNo + vbQuestion, MacroName) = vbNo Then
                Exit Sub
            Else
                Exit Do
            End If
        Else
            If WorkPart.Name = GetParent_Of_T(Ax, "Part").Name Then Exit Do
            Msg = "指定ﾎﾞﾃﾞｨと同一の座標系を選択して下さい!"
            MsgBox Msg, vbOKOnly + vbExclamation, MacroName
        End If
    Loop
    
    '距離測定
    Dim MaxLeng As Variant:
    MaxLeng = GetMaxSize_Body(WorkPart, TargetBody, Ax, Vec)
    
    'ﾎﾞﾃﾞｨ作成
    Dim MinBody As Body: Set MinBody = WorkPart.Bodies.Add
    MinBody.Name = "MinimumBox"
    Call ChangeColor(MinBody)
    
    'ｽｹｯﾁ
    Dim SupportRef As Reference
    If IsNothing(Ax) Then
        Set SupportRef = WorkPart.CreateReferenceFromGeometry(WorkPart.OriginElements.PlaneXY)
    Else
        Dim AxPlnRefs As Variant: AxPlnRefs = GetAxisPlaneRefs(Ax)
        Set SupportRef = AxPlnRefs(0)
    End If
    Dim Skt As Sketch: Set Skt = InitSketch(MinBody.Sketches, SupportRef, Ax)
    Call InitBox2D(Skt, MaxLeng)
    
    'ﾊﾟｯﾄﾞ
    Call InitPad(MinBody, Skt, MaxLeng)
    WorkPart.Update
End Sub

'***** PartDocument関連 *****
'全方向距離取得-ﾎﾞﾃﾞｨ
Private Function GetMaxSize_Body(ByVal Pt As Part, ByVal Body As AnyObject, _
                                 ByVal Ax As AxisSystem, Vec As Variant) As Variant
    Dim AxRef As Reference
    If Not IsNothing(Ax) Then
        Set AxRef = Pt.CreateReferenceFromObject(Ax)
    End If
    Dim Max#(): ReDim Max(UBound(Vec))
    Dim I&
    For I = 0 To UBound(Vec)
        Max(I) = (DmyLng - GetMaximumLength(Pt, Body, AxRef, Vec(I))) * IIf(I Mod 2 = 0, -1, 1)
    Next
    GetMaxSize_Body = Max
End Function

'距離取得
Private Function GetMaximumLength#(ByVal Pt As Part, ByVal Body As AnyObject, _
                                   ByVal AxRef As Reference, Vec As Variant)
    Dim Pln As HybridShapePlaneEquation
    Set Pln = CreatePlane(Pt, AxRef, Vec(0), Vec(1), Vec(2))
    GetMaximumLength = Pt.Parent.GetWorkbench("SPAWorkbench") _
                        .GetMeasurable(Pt.CreateReferenceFromObject(Body)) _
                        .GetMinimumDistance(Pt.CreateReferenceFromObject(Pln))
    Call Pt.HybridShapeFactory.DeleteObjectForDatum(Pln)
End Function

'平面作成
Private Function CreatePlane(ByVal Pt As Part, _
                             ByVal AxRef As Reference, _
                             ByVal A As Double, _
                             ByVal B As Double, _
                             ByVal C As Double) _
                             As HybridShapePlaneEquation
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Set CreatePlane = Fact.AddNewPlaneEquation(A, B, C, DmyLng)
    If Not AxRef Is Nothing Then
        CreatePlane.RefAxisSystem = AxRef
    End If
    Call Pt.UpdateObject(CreatePlane)
    Set Fact = Nothing
End Function

'T型のParent取得 Nameでのﾁｪｯｸも必要
Private Function GetParent_Of_T(ByVal AnyOj As AnyObject, ByVal t$) As AnyObject
    If TypeName(AnyOj) = TypeName(AnyOj.Parent) And _
       AnyOj.Name = AnyOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AnyOj) = t Then
        Set GetParent_Of_T = AnyOj
    Else
        Set GetParent_Of_T = GetParent_Of_T(AnyOj.Parent, t)
    End If
End Function

'ﾎﾞﾃﾞｨ選択
Private Function SelectBody(ByVal SelMsg$, ByVal Filter As Variant, _
                            ByVal Doc As PartDocument) As AnyObject
    Dim SelItem As AnyObject, Msg$
    Dim Pt As Part: Set Pt = Doc.Part
    Dim LeafBody As Body, LastFuture As AnyObject
    Do
        Set SelItem = SelectItem(SelMsg, Filter, Doc)
        If IsNothing(SelItem) Then Set SelectBody = SelItem: Exit Function '中止
        Set LeafBody = GetLeafBody(SelItem)
        If Not IsNothing(LeafBody) Then
            Set LastFuture = GetLastFuture(LeafBody, Pt)
            If LastFuture Is Nothing Then
                Msg = "空のﾎﾞﾃﾞｨは測定できません!"
                MsgBox Msg, vbOKOnly + vbExclamation, MacroName
            Else
                Exit Do
            End If
            Msg = "ﾎﾞﾃﾞｨの要素を選択して下さい!"
            MsgBox Msg, vbOKOnly + vbExclamation, MacroName
        End If
    Loop
    Set SelectBody = LastFuture
End Function

'選択
Private Function SelectItem(ByVal Msg$, ByVal Filter As Variant, _
                            ByVal Doc As Document) As AnyObject
    Dim Sel As Variant: Set Sel = Doc.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Set SelectItem = Nothing
            Exit Function
    End Select
    Set SelectItem = Sel.Item(1).Value
    Sel.Clear
End Function

'Treeに直接ぶら下がっているﾎﾞﾃﾞｨの取得
Private Function GetLeafBody(AnyOj As AnyObject) As Body
    If TypeName(AnyOj) = TypeName(AnyOj.Parent) Then
        Set GetLeafBody = Nothing
        Exit Function
    End If
    If TypeName(AnyOj.Parent) = "Bodies" Then
        If AnyOj.InBooleanOperation Then
            Set GetLeafBody = GetLeafBody(AnyOj.Parent)
        Else
            Set GetLeafBody = AnyOj
        End If
    Else
        Set GetLeafBody = GetLeafBody(AnyOj.Parent)
    End If
End Function

'Shapesから最後の活動化されたﾌｨｰﾁｬｰを取得
Private Function GetLastFuture(ByVal Shs As Shapes, ByVal Pt As Part) As AnyObject
    Dim I As Long
    For I = Shs.Count To 1 Step -1
        If Not IsEmpty(Shs.Item(I)) Then
            If False = Pt.IsInactive(Shs.Item(I)) Then '←Notじゃ上手く行かない
                Set GetLastFuture = Shs.Item(I)
                Exit Function
            End If
        End If
    Next
End Function

'座標系の各平面のﾚﾌｧﾚﾝｽの取得
'Return : 0-XY,1-YZ,2-ZY のﾚﾌｧﾚﾝｽ
Private Function GetAxisPlaneRefs(ByVal Ax As AxisSystem) As Variant ' Reference()
    Dim Pt As Part: Set Pt = GetParent_Of_T(Ax, "Part")
    Dim PlaneRef(2) As Reference
    Dim I&
    For I = 0 To UBound(PlaneRef)
        Set PlaneRef(I) = Pt.CreateReferenceFromBRepName(GetAxisPlaneBrepName(Ax, I), Ax)
    Next
    GetAxisPlaneRefs = PlaneRef
End Function

'座標系BrepNameの取得 - InternalName版
' PlaneN0 : 0-XY,1-YZ,2-ZYの何れか
Private Function GetAxisPlaneBrepName$(ByVal Ax As AxisSystem, ByVal PlaneNo&)
    Dim IntName$: IntName = Ax.GetItem("ModelElement").InternalName
    GetAxisPlaneBrepName = "RSur:(Face:(Brp:(" + IntName + ";" + CStr(PlaneNo + 1) + ");None:();Cf11:());" + _
                           "WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
End Function

'座標系の原点XYﾍﾞｸﾄﾙ取得
Private Function GetAxisOriVec(ByVal Ax As AxisSystem) As Variant
    Dim AxVri As Variant: Set AxVri = Ax
    Dim AryAxOri(2): Call AxVri.GetOrigin(AryAxOri)
    Dim AryAxXVec(2), AryAxYVec(2)
    Call AxVri.GetVectors(AryAxXVec, AryAxYVec)
    Dim Ary As Variant: Ary = Array_Join(AryAxOri, AryAxXVec)
    GetAxisOriVec = Array_Join(Ary, AryAxYVec)
End Function

'型ﾁｪｯｸ
Private Function IsType_Of_T(ByVal AnyOj As AnyObject, ByVal t$) As Boolean
    IsType_Of_T = IIf(TypeName(AnyOj) = t, True, False)
End Function


'***** Sketch関連 *****
'ｽｹｯﾁ作成
Private Function InitSketch(ByVal Skts As Sketches, _
                            ByVal SupportRef As Reference, _
                            ByVal Ax As AxisSystem) As Sketch
    Dim Skt As Sketch: Set Skt = Skts.Add(SupportRef)
    Set InitSketch = Skt
    If IsNothing(Ax) Then Exit Function
    
    Dim AxVar As Variant: Set AxVar = Ax
    Dim Ori(2) As Variant: Call AxVar.GetOrigin(Ori)
    Dim VecX(2) As Variant, VecY(2) As Variant
    Call AxVar.GetVectors(VecX, VecY)
    Dim SettingAbsData As Variant
    SettingAbsData = Array_Join(Ori, VecX)
    SettingAbsData = Array_Join(SettingAbsData, VecY)
    
    Dim SktVar As Variant: Set SktVar = Skt
    Call SktVar.SetAbsoluteAxisData(SettingAbsData)
    
End Function

'四角作成
Private Sub InitBox2D(ByVal Skt As Sketch, ByVal Poss As Variant)
    If Not UBound(Poss) = 5 Then Exit Sub
    
    Dim Fact2D As Factory2D: Set Fact2D = Skt.OpenEdition()
    
    Dim Pnt2D(3) As Point2D
    Set Pnt2D(0) = Fact2D.CreatePoint(Poss(MinMax.MinX), Poss(MinMax.MinY))
    Set Pnt2D(1) = Fact2D.CreatePoint(Poss(MinMax.MinX), Poss(MinMax.MaxY))
    Set Pnt2D(2) = Fact2D.CreatePoint(Poss(MinMax.MaxX), Poss(MinMax.MaxY))
    Set Pnt2D(3) = Fact2D.CreatePoint(Poss(MinMax.MaxX), Poss(MinMax.MinY))

    Dim Consts As Constraints: Set Consts = Skt.Constraints
    
    Call InitLine2D(Fact2D, Consts, Pnt2D(0), Pnt2D(1))
    Call InitLine2D(Fact2D, Consts, Pnt2D(1), Pnt2D(2))
    Call InitLine2D(Fact2D, Consts, Pnt2D(2), Pnt2D(3))
    Call InitLine2D(Fact2D, Consts, Pnt2D(3), Pnt2D(0))
    
    Skt.CloseEdition
End Sub

'線作成 - 可能なら垂直水平拘束
Private Sub InitLine2D(ByVal Fact2D As Factory2D, ByVal Csts As Constraints, _
                       ByVal PntSt As Point2D, ByVal PntEd As Point2D)
    Dim PntStVri As Variant: Set PntStVri = PntSt
    Dim PosSt(1) As Variant: Call PntStVri.GetCoordinates(PosSt)
    Dim PntEdVri As Variant: Set PntEdVri = PntEd
    Dim PosEd(1) As Variant: Call PntEdVri.GetCoordinates(PosEd)
    If Dist2D_Ary2Ary(PosSt, PosEd) < 0.001 Then Exit Sub
    
    Dim Line As Line2D
    Set Line = Fact2D.CreateLine(PosSt(0), PosSt(1), PosEd(0), PosEd(1))
    With Line
        .StartPoint = PntSt
        .EndPoint = PntEd
    End With
    
    Dim Ax2D As Axis2D
    Set Ax2D = GetParent_Of_T(Csts, "Sketch").GeometricElements.Item(1)
    Select Case True
        Case Abs(PosSt(0) - PosEd(0)) < 0.001
            Call InitConstraint(Csts, catCstTypeVerticality, Line, Ax2D.VerticalReference) '弟3,4逆NG
            Call InitConstraint(Csts, catCstTypeDistance, Ax2D.VerticalReference, Line, PosSt(0))
        Case Abs(PosSt(1) - PosEd(1)) < 0.001
            Call InitConstraint(Csts, catCstTypeHorizontality, Line, Ax2D.HorizontalReference) '弟3,4逆NG
            Call InitConstraint(Csts, catCstTypeDistance, Ax2D.HorizontalReference, Line, PosSt(1))
    End Select
End Sub

'拘束
Private Sub InitConstraint(ByVal Csts As Constraints, ByVal CstType As CatConstraintType, _
                           ByVal Itm1 As AnyObject, ByVal Itm2 As AnyObject, Optional ByVal Dist# = -1)
    Dim Pt As Part: Set Pt = GetParent_Of_T(Csts, "Part")
    Dim Cst As Constraint:
    Set Cst = Csts.AddBiEltCst(CstType, _
                               Pt.CreateReferenceFromObject(Itm1), _
                               Pt.CreateReferenceFromObject(Itm2))
    Cst.ModE = catCstModeDrivingDimension
    If Dist < 0.001 Then Exit Sub 'IsMissing(Dist)ﾀﾞﾒ?
    Dim Leng As Length: Set Leng = Cst.Dimension
    Leng.Value = Dist
End Sub

'***** Body関連 *****
'ﾊﾟｯﾄﾞ
Private Sub InitPad(ByVal Bdy As Body, ByVal Skt As Sketch, ByVal Poss As Variant)
    If Not UBound(Poss) = 5 Then Exit Sub
    
    Dim Pt As Part: Set Pt = GetParent_Of_T(Bdy, "Part")
    Dim Fact As ShapeFactory: Set Fact = Pt.ShapeFactory
    Dim Pad As Pad: Set Pad = Fact.AddNewPad(Skt, Poss(MinMax.MaxZ))
    Pad.DirectionOrientation = catRegularOrientation
    Dim MinZ As Length: Set MinZ = Pad.SecondLimit.Dimension
    MinZ.Value = Poss(MinMax.MinZ) * -1
End Sub

'色等変更
Private Sub ChangeColor(ByVal Itm As AnyObject)
    Dim Doc As PartDocument: Set Doc = 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
    Call Vis.SetRealColor(128, 64, 64, 1)
    Call Vis.SetRealOpacity(128, 1)
    Call Vis.SetRealWidth(1, 1)
    Call Vis.SetRealLineType(4, 1)
    Sel.Clear
End Sub


'***** Array関連 *****
'距離-配列同士
Private Function Dist2D_Ary2Ary(ByVal XY1 As Variant, ByVal XY2 As Variant)
    Dist2D_Ary2Ary = Sqr((XY2(0) - XY1(0)) * (XY2(0) - XY1(0)) + (XY2(1) - XY1(1)) * (XY2(1) - XY1(1)))
End Function

'配列の値が一致するか?
Private Function isArrayEqual(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Boolean
    isArrayEqual = False
    If Not IsArray(Ary1) Or Not IsArray(Ary2) Then Exit Function
    If Not UBound(Ary1) = UBound(Ary2) Then Exit Function
    Dim I&
    For I = 0 To UBound(Ary1)
        If Not Ary1(I) = Ary2(I) Then Exit Function
    Next
    isArrayEqual = True
End Function

'配列の連結
Private Function Array_Join(ByVal Ary1 As Variant, ByVal Ary2 As Variant)
    If Not IsArray(Ary1) Or Not IsArray(Ary2) Then Exit Function
    Dim StCount&: StCount = UBound(Ary1)
    ReDim Preserve Ary1(UBound(Ary1) + UBound(Ary2) + 1)
    Dim I&
    For I = StCount + 1 To UBound(Ary1)
        Ary1(I) = Ary2(I - StCount - 1)
    Next
    Array_Join = Ary1
End Function

'***** その他 *****
'Nothing 書き方に統一感が無い為
Private Function IsNothing(ByVal OJ As Variant) As Boolean
    IsNothing = OJ Is Nothing
End Function