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


寸法をクリックして直交する線を書く - C#ATIA


'vba Finish_Mark_ver0.0.1  using-'KCL0.0.12'  by Kantoku

Option Explicit

Private Type CompBase
    view As DrawingView
    scale2 As Double
End Type

Private Type TargetDim
    dim As DrawingDimension
    pos As Variant
End Type

Private Const EPS = 0.0001          'イコール判断

Sub CATMain()
    If Not CanExecute("DrawingDocument") Then Exit Sub
    Dim cmp_base As CompBase
    cmp_base = SelectComp()
    If cmp_base.view Is Nothing Then Exit Sub
    Dim doc As DrawingDocument
    Set doc = CATIA.ActiveDocument
    Dim sel As Selection
    Set sel = doc.Selection
    Dim msg As String
        Dim dim_info As TargetDim
        dim_info = SelectDimension(sel)
        If dim_info.dim Is Nothing Then Exit Sub
        Dim ac As DrawingView
        Set ac = doc.Sheets.ActiveSheet.Views.ActiveView
        Dim tg As DrawingView
        Set tg = KCL.GetParent_Of_T(dim_info.dim, "DrawingView")
        Dim tran_vec As Variant
        tran_vec = GetTransVec(ac, tg)
        dim_info.pos = Add2d(tran_vec, dim_info.pos)
        Dim dim_geo As Variant
        dim_geo = GetDimGeoInfo(dim_info.dim)
        Dim cmp_pos As Variant
        cmp_pos = GetMinPos(dim_geo, dim_info.pos)
        Dim cmp As DrawingComponent
        Set cmp = tg.Components.Add(cmp_base.view, cmp_pos(0)(0), cmp_pos(0)(1))
        cmp.angle = GetAng(cmp_pos(1), cmp_pos(2), dim_info.pos)
        cmp.scale2 = cmp_base.scale2
        msg = "宜しいですか?" & vbCrLf & _
            "(はい-配置 , いいえ-反転して配置 , キャンセル-配置を中止)"
        Dim btm_Opt As Long
        btm_Opt = vbYesNoCancel + vbInformation
        Select Case MsgBox(msg, vbYesNoCancel)
            Case vbYes
            Case vbNo
                cmp.angle = cmp.angle - PI '2*PI超えるとエラーかも
            Case vbCancel
                sel.Add cmp
        End Select
End Sub

Private Function IsDetailSheetView(ByVal v As DrawingView) As Boolean
    Dim dmy As Variant
    On Error Resume Next
    Set dmy = v.GenerativeLinks
    If err.Number = 0 Then
        IsDetailSheetView = False
        IsDetailSheetView = True
    End If
    On Error GoTo 0
End Function

Private Function SelectComp() As CompBase
    Dim msg$
    msg = "2Dコンポーネント 又は ディテールビューを選択 : ESCキー 終了"
    Dim Itm As AnyObject
    Set Itm = KCL.SelectItem(msg, "DrawingComponent,DrawingView")
    If Itm Is Nothing Then Exit Function
    Dim cb As CompBase
    If TypeName(Itm) = "DrawingComponent" Then
        Set cb.view = Itm.CompRef
        cb.scale2 = Itm.scale2
        SelectComp = cb
        Exit Function
    End If
    If IsDetailSheetView(Itm) Then
        Set cb.view = Itm
        cb.scale2 = Itm.scale2 '1#
        SelectComp = cb
        Exit Function
    End If
    MsgBox "選択可能なビューは、ディテールのもののみです"
End Function

Private Function SelectDimension(ByVal sel As Variant) As TargetDim
    Dim msg As String
    msg = "寸法線をクリックして下さい"
    Dim filter As Variant
    filter = Array("DrawingDimension")
    Dim ojSelected As Variant 'Boolean
    Dim winLocat(1) As Variant 'Double
    Dim status As String
    status = "MouseMove"

    Dim tgt As TargetDim
        status = sel.IndicateOrSelectElement2D( _
            msg, _
            filter, _
            False, _
            False, _
            True, _
            ojSelected, _
        If status = "Normal" And sel.Count2 > 0 Then
            Exit Do
        End If
        If status = "Cancel" Then
            Exit Function
        End If
    Set tgt.dim = sel.Item(1).Value
    tgt.pos = winLocat
    SelectDimension = tgt
End Function

'param:s_pos-寸法線スタート位置 e_pos-寸法線エンド位置 ref_pos-クリック位置
Private Function GetAng( _
    ByVal s_pos As Variant, _
    ByVal e_pos As Variant, _
    ByVal ref_pos As Variant) As Double
    Dim dim_vec As Variant
    dim_vec = Sub2d(s_pos, e_pos)
    Dim ref_vec As Variant
    ref_vec = Sub2d(s_pos, ref_pos)
    Dim crs_vec As Variant
    crs_vec = Cross2d(dim_vec, ref_vec)
    Dim dim_rad As Double
    dim_rad = Atn2(dim_vec(1), dim_vec(0))
    GetAng = dim_rad
    If Sgn(crs_vec) > 0 Then
        GetAng = GetAng + PI
    End If
End Function

'0-線上xy 1-線始点xy 2-線終点xy
Private Function GetMinPos( _
    ByVal geos As Variant, _
    ByVal pos As Variant) As Variant
    Dim min As Double
    min = 1000000000
    Dim min_lin As Variant
    Dim tmp As Double
    Dim i As Long
    For i = 0 To UBound(geos)
        tmp = Dist_AB_C(geos(i)(0), geos(i)(1), pos)
        If tmp < min Then
            min = tmp
            min_lin = Array(geos(i)(0), geos(i)(1))
        End If
    Dim min_nml As Variant
    min_nml = Normaliz2d(min_lin(0), min_lin(1))
    Dim lng As Double
    lng = Dot2d(min_nml, Sub2d(pos, min_lin(0)))
    Dim xy As Variant
    xy = Add2d(min_lin(0), Array(min_nml(0) * lng, min_nml(1) * lng))
    GetMinPos = Array(xy, min_lin(0), min_lin(1))
End Function

Private Function GetTransVec( _
    ByVal act_v As DrawingView, _
    ByVal tgt_v As DrawingView) As Variant
    GetTransVec = Sub2d( _
        Array(act_v.xAxisData, act_v.yAxisData), _
        Array(tgt_v.xAxisData, tgt_v.yAxisData))
End Function

'寸法線、補助線座標値取得 0-寸,1-補1,2-補2
Private Function GetDimGeoInfo( _
    ByVal drwDim As DrawingDimension) As Variant
    Dim dl As Variant 'DrawingDimLine or DrawingDimExtLine
    Dim dimgeo(3) As Variant
    Set dl = drwDim.GetDimLine
    Call dl.GetGeomInfo(dimgeo)
    Dim ex1geo(3) As Variant
    Set dl = drwDim.GetDimExtLine
    Call dl.GetGeomInfo(1, ex1geo)
    Dim ex2geo(3) As Variant
    Call dl.GetGeomInfo(2, ex2geo)
    GetDimGeoInfo = Array( _
        Array(Array(dimgeo(0), dimgeo(1)), Array(dimgeo(2), dimgeo(3))), _
        Array(Array(dimgeo(0), dimgeo(1)), Array(ex1geo(0), ex1geo(1))), _
        Array(Array(dimgeo(2), dimgeo(3)), Array(ex2geo(0), ex2geo(1))) _
End Function

'*** Math ***
Private Function PI() As Double
    PI = Atn(1) * 4
End Function

Private Function ArcCos(ByVal v As Double) As Double
    ArcCos = Atn(-v / Sqr(-v * v + 1)) + 2 * Atn(1)
End Function

Private Function Atn2(ByVal y As Double, ByVal x As Double) As Double
    Select Case x
        Case Is > 0
            Atn2 = Atn(y / x)
        Case Is < 0
            Atn2 = Atn(y / x) + PI * Sgn(y)
            If y = 0 Then Atn2 = Atn2 + PI
        Case Is = 0
            Atn2 = (PI * 0.5) * Sgn(y)
    End Select
End Function

Private Function LengSqr(ByVal p1 As Variant, ByVal p2 As Variant) As Double
    Dim A#: A = p2(0) - p1(0)
    Dim B#: B = p2(1) - p1(1)
    LengSqr = A * A + B * B
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

Private Function Dist_AB_C(ByVal A As Variant, ByVal B As Variant, ByVal C As Variant) As Double
    Dist_AB_C = Lng_AB_C(A, B, C)
End Function

Private Function Lng_AB_C(ByVal A As Variant, ByVal B As Variant, ByVal C As Variant) As Double
    Lng_AB_C = Abs(Cross2d(Sub2d(B, A), Sub2d(C, A))) / Abs(Sqr(LengSqr(B, A)))
End Function

Private Function Lng_V_P(ByVal v As Variant, ByVal p As Variant) As Double
    Lng_V_P = Abs(Cross2d(v, p))
End Function

Private Function Normaliz2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Dim vec: vec = Sub2d(V2, V1)
    Dim tmp: tmp = Sqr(Dot2d(vec, vec))
    If EQ(tmp, 0#) Then
        Normaliz2d = Empty
        Exit Function
    End If
    Normaliz2d = Array(vec(0) / tmp, vec(1) / tmp)
End Function

Private Function Add2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Add2d = Array(V1(0) + V2(0), V1(1) + V2(1))
End Function

Private Function Sub2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Sub2d = Array(V1(0) - V2(0), V1(1) - V2(1))
End Function

Private Function Dot2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
    Dot2d = V1(0) * V2(0) + V1(1) * V2(1)
End Function

Private Function Cross2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
    Cross2d = V1(0) * V2(1) - V1(1) * V2(0)
End Function




存在しているビューに配置します。こちらの "残念、そこじゃないんだよね" 対策。
寸法をクリックして直交する線を書く - C#ATIA



ファンネル - C#ATIA