ﾀｲﾄﾙだけでは伝わりにくいのですが、先日行った作業用対策のﾏｸﾛです。
（他人には役に立たないと思います）
結果的にはｵﾌｾｯﾄ平面を作成するだけなのですが、何といいますか面倒なんです。
赤色はXY平面、黄色はZX平面で紫色のBodyの面はZX平面と平行です。
紫色と同じ位置に、ZX平面からのｵﾌｾｯﾄ平面を作成したいのです。
手動で行うのであれば･･･ ” 平面からｵﾌｾｯﾄ " でZX平面を指定し
"ｵﾌｾｯﾄ" 部分のｺﾝﾃｷｽﾄﾒﾆｭｰで "2要素間を測定..." を選択。
ZX平面と紫色の面を測定し、ﾘﾝｸさせたくない為(あくまで数値だけ欲しい)
"測定を保持" のﾁｪｯｸを外してOKです。
更に、ZX平面のプラス側だったため、"Y+28.296mm” とﾘﾈｰﾑ。
が、一番操作が速そうな気がしてます、が面倒なんです。
で、作ったのがこちらのﾏｸﾛです。
想像以上に大規模になってしまいました････。
Option Explicit
Private Const PRIORITY_ORIGINPLANE = True
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
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
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
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
Private Function GetMeasurable(ByVal pt As PART, ByVal p1)
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
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
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
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
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
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
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
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にあるのかな？）
