肉マシマシ - C#ATIA

食べ物のお話じゃなくて、CATIAです。

左側の物を加工しようと思った際、右の半透明の形状の材料を
用意するとします。
（ケミウッドで、直方体を積み重ねた形状です・・接着剤で）

材料を用意するサイズとしては、半透明の形状で良いのですが、
実際にCAMでツールパスを作成する際、半分ぐらいの確率で
外周部分の作成されない場合があります。

仕上がり形状と材料形状と加工代等の関係からだとは、
理解しています。

CAMとしての簡単な解決方法は、一回り大きなサイズの材料に
すれば良いのですが、実際の材料を用意する場合、
かっ飛ばしてしまう部分を大きくしても単に無駄です。

その為、実際の材料用のデータに "厚み" でちょっとだけ
肉増ししたデータをCAMで利用すれば良いだけです。

今まで、手でチマチマ厚みを付ける面を選択していましたが、
最近ちょっとやる気も出てきたので、マクロを作成してみました。

'vba using-'KCL0.0.12'  by Kantoku

Option Explicit

'増肉量
Private Const LENGTH = 5#

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not KCL.CanExecute("PartDocument") Then Exit Sub
    
    'ボディ選択
    Dim msg  As String
    msg = "肉付けするボディを選択して下さい : ESCｷｰ 終了"
    
    Dim bdy As body
    Set bdy = KCL.SelectItem(msg, "Body")
    If bdy Is Nothing Then
        Exit Sub
    End If
    
    '面取得
    Dim surfs As Collection
    Set surfs = getSurf(bdy)
    
    '垂直面取得
    Dim vSurfs As Collection
    Set vSurfs = getVerticalSurfaceList( _
        surfs _
    )
    
    '問い合わせ
    If vSurfs.count < 1 Then
        msg = "垂直面がありません"
        MsgBox msg
        Exit Sub
    End If

    msg = vSurfs.count & "ヶ所の面を増肉します。宜しいですか?"
    If MsgBox(msg, vbOKCancel + vbQuestion) = vbCancel Then
        Exit Sub
    End If
    
    '増肉
    Call addThickness(vSurfs, LENGTH)

End Sub


Private Sub addThickness( _
    ByVal surfs As Collection, _
    ByVal LENGTH As Double)

    Dim pt As part
    Set pt = KCL.GetParent_Of_T(surfs.Item(1), "Part")

    Dim backup As AnyObject
    Set backup = pt.InWorkObject

    Dim bdy As body
    Set bdy = KCL.GetParent_Of_T(surfs.Item(1), "Body")
    pt.InWorkObject = bdy

    Dim fact As ShapeFactory
    Set fact = pt.ShapeFactory

    Dim refDmy As Reference
    Set refDmy = pt.CreateReferenceFromName("")

    Dim thick As Thickness
    Set thick = fact.AddNewThickness(refDmy, LENGTH)

    Dim ref As Reference
    For Each ref In surfs
        thick.AddFaceToThicken ref
    Next
    
    pt.UpdateObject bdy
    
    pt.InWorkObject = backup
    
End Sub


Private Function getVerticalSurfaceList( _
    ByVal surfs As Collection) _
    As Collection

    If surfs.count < 1 Then
        Set getVerticalSurfaceList = New Collection
        Exit Function
    End If

    Dim pt As part
    Set pt = KCL.GetParent_Of_T(surfs.Item(1), "Part")
    
    Dim meas As Measurable
    Set meas = getMeasurable( _
        pt, _
        pt.OriginElements.PlaneXY _
    )
    
    Dim vSurfs As Collection
    Set vSurfs = New Collection
    
    On Error Resume Next

    Dim surf, ang As Double
    For Each surf In surfs
        ang = meas.GetAngleBetween(surf)
    
        If (90 - ang) < 0.001 Then
            vSurfs.Add surf
        End If
    Next
    
    On Error GoTo 0
    
    Set getVerticalSurfaceList = vSurfs
    
End Function


'Measurable
Private Function getMeasurable( _
    ByVal pt As part, _
    ByVal entity _
    ) 'As Measurable
    
    Dim wb, meas As Measurable
    Set wb = pt.Parent.GetWorkbench("SPAWorkbench")
    Set getMeasurable = wb.getMeasurable(entity)

End Function


Private Function getSurf( _
    ByVal bdy As body) _
    As Collection

    Dim pt As part
    Set pt = KCL.GetParent_Of_T(bdy, "Part")

    Dim doc As PartDocument
    Set doc = pt.Parent
    
    Dim sel As Selection
    Set sel = doc.Selection
    sel.Clear
    
    CATIA.HSOSynchronized = False
    
    sel.Add bdy
    sel.Search "Topology.CGMFace,sel"

    If sel.Count2 < 1 Then
        Set getSurf = Nothing
    End If
        
    Dim surfs As Collection
    Set surfs = New Collection
    
    Dim i As Long
    For i = 1 To sel.Count2
        surfs.Add sel.Item2(i).value
    Next
    
    sel.Clear
    
    CATIA.HSOSynchronized = True
    
    Set getSurf = surfs

End Function