タイトルだけでは伝わりにくいのですが、先日行った作業用対策のマクロです。
(他人には役に立たないと思います)
結果的にはオフセット平面を作成するだけなのですが、何といいますか面倒なんです。
赤色は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にあるのかな?)