-2

我已经标记了发生错误的行。

语言="VBSCRIPT"

Sub CATMain()

Dim ProdDoc As Document
Set ProdDoc = CATIA.ActiveDocument

Dim product1 As Product
Set product1 = ProdDoc.Product

Dim products1 As Products
Set products1 = product1.Products

Dim product2 As Product
Set product2 = products1.AddNewComponent("Part", "NewPart1")

Dim documents1 As Documents
Set documents1 = CATIA.Documents

Dim partDocument1 As Document
Set partDocument1 = documents1.Item("NewPart1.CATPart")

Dim NewPart1 As Part
Set NewPart1 = partDocument1.Part

Dim hybridShapeFactory1 As Factory
Set hybridShapeFactory1 = NewPart1.HybridShapeFactory

Dim parameters1 As Parameters
Set parameters1 = NewPart1.Parameters

Dim oSel As Selection
Set oSel = prodDoc.Selection

Dim point_ref 
Dim line_ref 
Dim Point As Reference 
Dim Line As Reference

'选择点和边的变量

 Dim iot1(0)
  iot1(0) = "Vertex"
  Dim iot2(0)
   iot2(0)="TriDimFeatEdge"

  Status = oSel.SelectElement2(iot1, "Select a line", False)

  msgbox oSel.Item(1).Type

  set point_ref = oSel.Item(1).Value

  oSel.Clear

  Status = oSel.SelectElement2(iot2, "Select a line", False)

  msgbox oSel.Item(1).Type

  set line_ref = oSel.Item(1).Value

  oSel.Clear

' 传递选定的点和线来创建一个新平面。' 使用垂直于曲线的方法创建平面。

  Dim hybridShapePlaneNormal1 As HybridShapePlaneNormal
  Set hybridShapePlaneNormal1 = hybridShapeFactory1.AddNewPlaneNormal(line_ref, point_ref)

  Dim bodies1 As Bodies
  Set bodies1 = NewPart1.Bodies

  Dim body1 As Body
  Set body1 = bodies1.Item("PartBody")

' This is where I get error

  body1.InsertHybridShape hybridShapePlaneNormal1  '{Error - Method InsertHybridShape failed}

  NewPart1.InWorkObject = hybridShapePlaneNormal1
  NewPart1.Update 



End Sub
4

2 回答 2

0

我已将您的脚本简化为可以正常工作的内容。我怀疑您遇到错误是因为您在产品的上下文中工作。在这种情况下，@kantoku 的以下答案可以使用复制粘贴特殊功能正确处理。在产品上下文中创建脚本部件要复杂一些。您可能需要activate新插入的产品。无论如何，仅在零件上下文中尝试以下代码（您需要创建零件和一些基本实体（例如立方体）：

Option Explicit
Sub MakePointOnPlane()

Dim partDoc As PartDocument
Dim oSel
Dim status
Dim myPart As Part
Dim HSF As HybridShapeFactory

Set partDoc = CATIA.ActiveDocument
Set oSel = partDoc.Selection
Set myPart = partDoc.Part
Set HSF = myPart.HybridShapeFactory

Dim point_ref
Dim line_ref
Dim Point As Reference
Dim Line As Reference
'Variables to pick point and edge

 Dim iot1(0)
  iot1(0) = "Vertex"
  Dim iot2(0)
   iot2(0) = "TriDimFeatEdge"

  status = oSel.SelectElement2(iot1, "Select a vertex", False)

  MsgBox oSel.Item(1).Type

  Set point_ref = oSel.Item(1).Value

  oSel.Clear

  status = oSel.SelectElement2(iot2, "Select a line", False)

  MsgBox oSel.Item(1).Type

  Set line_ref = oSel.Item(1).Value

  oSel.Clear
' Passing selected point and line to create a new plane. ' The plane is created using method normal to curve.

  Dim hybridShapePlaneNormal1 As HybridShapePlaneNormal
  Set hybridShapePlaneNormal1 = HSF.AddNewPlaneNormal(line_ref, point_ref)

  Dim body1 As Body

  Set body1 = myPart.Bodies.GetItem("PartBody")

  Dim myPlane As Variant
  Set myPlane = hybridShapePlaneNormal1
  body1.InsertHybridShape hybridShapePlaneNormal1
  myPart.InWorkObject = hybridShapePlaneNormal1
  myPart.Update



End Sub
于 2015-10-27T01:27:00.927 回答
-1

试试看：

'CreateLinkedPlane - vba
Option Explicit

Type ItemPart
    Item As AnyObject
    Part As Part
End Type

Sub CATMain()
    'ﾌﾟﾛﾀﾞｸﾄﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not IsProductDocument Then
        MsgBox "Please open the CATProduct File!!"
        End
    End If

    '点の選択
    Dim SelPoint As ItemPart
    SelPoint = SelectItem(VertexFilter, "Select a Point　/ [Esc]=Cancel")

    '線の選択
    Dim SelLine As ItemPart
    SelLine = SelectItem(StraightLineFilter, "Select a line　/ [Esc]=Cancel")

    'ﾘﾝｸ元点作成
    Dim Point As ItemPart
    Point = CreateHSExtract(SelPoint)

    'ﾘﾝｸ元線作成
    Dim Normal As ItemPart
    Normal = CreateHSExtract(SelLine)

    'Partの追加
    Dim NewPart As Part
    Set NewPart = AddNewPart

    'ﾘﾝｸﾍﾟｰｽﾄ
    Dim Items(2) As ItemPart
    Items(1) = Point
    Items(2) = Normal
    Dim Point_Normal_References As Collection
    Set Point_Normal_References = CopyPaste_ResultWithLink(Items, NewPart)

    '平面作成
    Call CreatePlane(Point_Normal_References(1), Point_Normal_References(2))

    '終わり
    MsgBox "Finish"
End Sub

'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
Private Function IsProductDocument() As Boolean
    On Error Resume Next
       Dim temp As ProductDocument
       Set temp = CATIA.ActiveDocument
       IsProductDocument = IIf(Err.Number = 0, True, False)
    On Error GoTo 0
End Function

'平面作成
Private Sub CreatePlane(PointRef As Reference, NormalRef As Reference)
    Dim WorkPart As Part
    Set WorkPart = GetPart(PointRef)

    Dim HSFact As HybridShapeFactory
    Set HSFact = WorkPart.HybridShapeFactory

    Dim HSPlaneNormal As HybridShapePlaneNormal
    Set HSPlaneNormal = HSFact.AddNewPlaneNormal(NormalRef, PointRef)

    Dim HBody As HybridBody
    Set HBody = WorkPart.HybridBodies.Add
    Call HBody.AppendHybridShape(HSPlaneNormal)
    Call WorkPart.UpdateObject(HSPlaneNormal)
End Sub

'ｺﾋﾟﾍﾟ
Private Function CopyPaste_ResultWithLink(Items() As ItemPart, TargetPart As Part) As Collection
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    Dim i As Long
    With Sel
        .Clear
        For i = 1 To UBound(Items)
            Call .Add(Items(i).Item)
        Next
        .Copy
        .Clear
        Call .Add(TargetPart)
        Call .PasteSpecial("CATPrtResult")
        TargetPart.Update
        'ここでﾍﾟｰｽﾄしたｱｲﾃﾑ拾う
        Dim Refs As New Collection
        For i = 1 To .Count2
            Call Refs.Add(.Item2(i).Reference)
        Next
        .Clear
    End With
    Call ItemHide(TargetPart.HybridBodies.Item(1))
    Set CopyPaste_ResultWithLink = Refs
End Function

'Partの追加
Private Function AddNewPart() As Part
    Dim Dammy As Products
    Set Dammy = CATIA.ActiveDocument.Product.Products.AddNewComponent("Part", "")

    Dim Docs As Documents
    Set Docs = CATIA.Documents

    Set AddNewPart = Docs.Item(Docs.Count).Part
End Function

'抽出
Private Function CreateHSExtract(I_P As ItemPart) As ItemPart
    Dim Ref As Reference
    Set Ref = I_P.Part.CreateReferenceFromBRepName(GetBrepName(I_P.Item.Name), I_P.Item.Parent)

    Dim HSExtract As HybridShapeExtract
    Set HSExtract = I_P.Part.HybridShapeFactory.AddNewExtract(Ref)
    With HSExtract
        .PropagationType = 3
        .ComplementaryExtract = False
        .IsFederated = False
    End With

    Dim HBody As HybridBody
    Set HBody = I_P.Part.HybridBodies.Add
    HBody.Name = "ExportItem"
    Call ItemHide(HBody)

    Call HBody.AppendHybridShape(HSExtract)
    Call I_P.Part.UpdateObject(HSExtract)

    Dim ExtI_P As ItemPart
    Set ExtI_P.Item = HSExtract
    Set ExtI_P.Part = I_P.Part
    CreateHSExtract = ExtI_P
End Function

'Partの取得
Private Function GetPart(ByVal OJ As AnyObject) As Part
    Select Case TypeName(OJ.Parent)
        Case "Part"
            Set GetPart = OJ.Parent
        Case "Application"
            Set GetPart = Nothing
        Case Else
            Set GetPart = GetPart(OJ.Parent)
    End Select
End Function

'SelectElement用BrapName取得-thanks coe
Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

'非表示
Private Sub ItemHide(Item As AnyObject)
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    With Sel
        .Clear
        Call .Add(Item)
        Call .VisProperties.SetShow(catVisPropertyNoShowAttr)
        .Clear
    End With
    Set Sel = Nothing
End Sub

'選択
Private Function SelectItem(Filter, Msg As String) As ItemPart
    Dim Sel 'As selection
    Set Sel = CATIA.ActiveDocument.Selection

    With Sel
        .Clear
        If "Cancel" = .SelectElement2(Filter, Msg, False) Then
            Call MsgBox("Cancellation!")
            End
        End If

        Dim I_P As ItemPart
        Set I_P.Item = .Item(1).Value
        Set I_P.Part = GetPart(I_P.Item)
        If I_P.Part Is Nothing Then
            Call MsgBox("Cancellation!")
            End
        End If
        .Clear
    End With
    SelectItem = I_P
    Set Sel = Nothing
End Function

'SelectElement用直線ﾌｨﾙﾀｰ
Private Function StraightLineFilter() As Variant
    Dim Ary(1) As Variant
    Ary(0) = "RectilinearMonoDimFeatEdge"
    Ary(1) = "RectilinearTriDimFeatEdge"
    StraightLineFilter = Ary
End Function

'SelectElement用点ﾌｨﾙﾀｰ
Private Function VertexFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Vertex"
    VertexFilter = Ary
End Function
于 2015-10-18T01:08:31.553 回答