01-code.bas

CATIA二次开发

Attribute VB_Name = "functions"
Option Explicit

Sub IndicateOrSelectElement2DSample()

    InitCATIADrawing False
    
    Dim Document, Selection, DrawingSheets, DrawingSheet, DrawingViews
    Dim WindowLocation(1), DrawingView, Factory2D, Radius, Circle2D
    Dim HardCodedPoint, Status, XCenter, YCenter, InputObjectType(0)
    Dim TempCircleHasBeenCreatedAtLeastOnce, ExistingPoint
    Dim ObjectSelected
    
    Set Document = CATIA.ActiveDocument
    Set Selection = Document.Selection
    Set DrawingSheets = Document.Sheets
    Set DrawingSheet = DrawingSheets.ActiveSheet
    Set DrawingViews = DrawingSheet.Views
    Set DrawingView = DrawingViews.ActiveView
    Set Factory2D = DrawingView.Factory2D
    
    '创建一个点
    Set HardCodedPoint = Factory2D.CreatePoint(700#, 400#)
    HardCodedPoint.ReportName = 1
    HardCodedPoint.Construction = False
    
    '假设用户在屏幕上单击确定了圆心位置
    Status = Document.Indicate2D("单击以确定圆心位置", WindowLocation)
    If (Status = "Cancel" Or Status = "Undo" Or Status = "Redo") Then
        Exit Sub
    End If
    
    XCenter = WindowLocation(0)
    YCenter = WindowLocation(1)
    
    '假设用户在屏幕上指定了一位置或选择了一个点
    InputObjectType(0) = "Point2D"
    Status = "MouseMove"
    TempCircleHasBeenCreatedAtLeastOnce = 0
    Status = Selection.IndicateOrSelectElement2D _
        ("选择一个点或在屏幕上单击以确定圆半径", _
        InputObjectType, True, True, True, _
        ObjectSelected, WindowLocation)
    
    '用户移动鼠标且不单击时进行循环
    Do While (Status = "MouseMove")
        If (TempCircleHasBeenCreatedAtLeastOnce) Then
            Selection.Add Circle2D
            Selection.Delete
        End If
    
        Radius = Sqr(((WindowLocation(0) - XCenter) * (WindowLocation(0) - XCenter)) + _
                     ((WindowLocation(1) - YCenter) * (WindowLocation(1) - YCenter)))
        Set Circle2D = Factory2D.CreateClosedCircle(XCenter, YCenter, Radius)
        TempCircleHasBeenCreatedAtLeastOnce = 1
    
        Status = Selection.IndicateOrSelectElement2D _
            ("选择一个点或在屏幕上单击以确定圆半径", _
            InputObjectType, True, True, True, _
            ObjectSelected, WindowLocation)
    Loop
    
    '用户选择取消则退出程序
    If (Status = "Cancel" Or Status = "Undo" Or Status = "Redo") Then
        If (TempCircleHasBeenCreatedAtLeastOnce) Then
            Selection.Add Circle2D
            Selection.Add HardCodedPoint
            Selection.Delete
        End If
        Exit Sub
    End If
    
    '检测可能选中的点
    If (ObjectSelected) Then
        Set ExistingPoint = Selection.Item(1).Value
        ExistingPoint.GetCoordinates WindowLocation
        Selection.Clear
    End If
    
    '删除临时创建的圆
    If (TempCircleHasBeenCreatedAtLeastOnce) Then
        Selection.Add Circle2D
        Selection.Delete
    End If
    
    '创建所需的圆，并选中
    Radius = Sqr(((WindowLocation(0) - XCenter) * (WindowLocation(0) - XCenter)) + _
                 ((WindowLocation(1) - YCenter) * (WindowLocation(1) - YCenter)))
    Set Circle2D = Factory2D.CreateClosedCircle(XCenter, YCenter, Radius)
    Selection.Add Circle2D

End Sub

Sub IndicateOrSelectElement3DSample()
    
    InitCATIAPart False
    
    Dim Selection, HybridShapePlane, PlaneReference, HardCodedPoint, Point
    Dim InputObjectType(0), WindowLocation2D(1), WindowLocation3D(2)
    Dim TempPointHasBeenCreatedAtLeastOnce, Status
    Dim ObjectSelected, ExistingPoint
    
    Set Selection = oPartDoc.Selection
    
    Set oHBody = oHBodies.Item("几何图形集.1")
    Set HybridShapePlane = oHBody.HybridShapes.Item("平面.1")
    Set PlaneReference = oPart.CreateReferenceFromObject(HybridShapePlane)
    
    '先创建一个点
    Set HardCodedPoint = oHSF.AddNewPointOnPlane(PlaneReference, 30, 30)
    oHBody.AppendHybridShape HardCodedPoint
    oPart.Update
    
    '假设用户在文档窗口中指定一个点
    InputObjectType(0) = "HybridShapePointOnPlane"
    Status = "MouseMove"
    TempPointHasBeenCreatedAtLeastOnce = 0
    Selection.Clear
    Status = Selection.IndicateOrSelectElement3D _
        (HybridShapePlane, "select a point or click to locate the point", _
        InputObjectType, False, False, True, _
        ObjectSelected, WindowLocation2D, WindowLocation3D)
    
    '鼠标移动时进行循环
    Do While (Status = "MouseMove")
        If (TempPointHasBeenCreatedAtLeastOnce) Then
            Selection.Add Point: Selection.Delete
        End If
        Set Point = oHSF.AddNewPointOnPlane(PlaneReference, WindowLocation2D(0), WindowLocation2D(1))
        oHBody.AppendHybridShape Point
        oPart.Update
        TempPointHasBeenCreatedAtLeastOnce = 1
        
        Status = Selection.IndicateOrSelectElement3D _
            (HybridShapePlane, "select a point or click to locate the point", _
            InputObjectType, False, False, True, _
            ObjectSelected, WindowLocation2D, WindowLocation3D)
    Loop
    
    '用户选择取消，退出程序
    If (Status = "Cancel" Or Status = "Undo" Or Status = "Redo") Then
        If (TempPointHasBeenCreatedAtLeastOnce) Then
            Selection.Add Point
            Selection.Add HardCodedPoint
            Selection.Delete
            oPart.Update
        End If
        Exit Sub
    End If
    
    '检测可能选中的点
    If (ObjectSelected) Then
        Set ExistingPoint = Selection.Item(1).Value
        WindowLocation2D(0) = ExistingPoint.XOffset.Value
        WindowLocation2D(1) = ExistingPoint.YOffset.Value
        Selection.Clear
    End If
    
    '删除临时创建的点
    If (TempPointHasBeenCreatedAtLeastOnce) Then
        Selection.Add Point
        Selection.Delete
    End If
    
    '创建所需的点
    Set Point = oHSF.AddNewPointOnPlane(PlaneReference, WindowLocation2D(0), WindowLocation2D(1))
    oHBody.AppendHybridShape Point
    
    oPart.Update
    
End Sub

Sub SelectElement2Sample()

    InitCATIAPart False
    
    Dim InputObjectType(0), SketchForPad, Status, Selection, oPad
    Set Selection = oPartDoc.Selection
    
    InputObjectType(0) = "Sketch"
    Status = Selection.SelectElement2(InputObjectType, "请选择草绘特征", True)
    
    If ((Status = "Cancel") Or (Status = "Undo")) Then
        'Cancel和Undo的代码写在这里，这里我们退出程序
        Exit Sub
    ElseIf Status = "Redo" Then
        'Redo的代码写在这里
    ElseIf (Status <> "Redo") Then
        Set SketchForPad = Selection.Item(1).Value
        '创建拉伸体
        Set oPad = oSF.AddNewPad(SketchForPad, 20)
        oPart.Update
    End If

End Sub

Sub SelectElement3Sample()
    
    InitCATIAPart False
    
    Dim Selection, OriginElements, Plane, PlaneReference, Status
    Dim InputObjectType(0), PointIndex, PointReference, HybridShapeSymmetry
    
    Set Selection = oPartDoc.Selection
    
    Set oHBody = AddHBody("镜像")
    Set OriginElements = oPart.OriginElements
    Set Plane = OriginElements.PlaneZX
    Set PlaneReference = oPart.CreateReferenceFromObject(Plane)
    
    '用户选择多个点，可以圈选
    InputObjectType(0) = "Point"
    Status = Selection.SelectElement3 _
        (InputObjectType, "Select points", True, CATMultiSelTriggWhenSelPerf, False)
    If (Status = "Cancel") Then Exit Sub
    For PointIndex = 1 To Selection.Count
        
        Set PointReference = oPart.CreateReferenceFromObject(Selection.Item(PointIndex).Value)
        Set HybridShapeSymmetry = oHSF.AddNewSymmetry(PointReference, PlaneReference)
        oHBody.AppendHybridShape HybridShapeSymmetry
        oPart.Update
    
    Next
    
    Selection.Clear

End Sub

Sub FilterCorrespondenceSample()

    InitCATIAPart False
    
    Dim Selection, InputObjectType(0), Status
    Dim Edge(), EdgeCount, SelectedEdge, Fillet
    Dim AllFit As Boolean, Found As Boolean, AllEdgesHaveBeenSelected As Boolean
    Dim EdgeIndex As Long, EdgeIndex2 As Long
    Dim AlreadySelectedEdgeIndex As Long, OtherEdgeAnswer As Long
    
    Set Selection = oPartDoc.Selection
    EdgeCount = 0
    
    InputObjectType(0) = "TriDimFeatEdge"
    AllFit = Selection.FilterCorrespondence(InputObjectType)
    If (AllFit) Then
        '加入已选中边界
        For EdgeIndex = 0 To Selection.Count - 1
            ReDim Preserve Edge(EdgeCount)
            Set Edge(EdgeCount) = Selection.Item(EdgeIndex + 1).Value
            EdgeCount = EdgeCount + 1
        Next
    Else
        Selection.Clear
    End If
    
    '循环选取
    AllEdgesHaveBeenSelected = False
    Do While (Not AllEdgesHaveBeenSelected)
    
    
        '要求用户选择边界
        Status = Selection.SelectElement2(InputObjectType, "请选择边界", False)
        If (Status = "Cancel") Then
            Selection.Clear
            Exit Sub
        End If
    
        '保存选择的边界
        Set SelectedEdge = Selection.Item(1).Value
    
        '检查边界是否已存在
        EdgeIndex2 = 0
        Found = False
        Do While ((EdgeIndex2 < EdgeCount) And (Not Found))
            Selection.Add Edge(EdgeIndex2)
            If (Selection.Count = 1) Then
                Found = True
                AlreadySelectedEdgeIndex = EdgeIndex2
            Else
                Selection.Clear
                Selection.Add SelectedEdge
            End If
            EdgeIndex2 = EdgeIndex2 + 1
        Loop
    
        '若边界已存在则移除，否则添加
        If (Found) Then
    
            '边界已存在，从集合移除
            For EdgeIndex2 = AlreadySelectedEdgeIndex To EdgeCount - 2
                Set Edge(EdgeIndex2) = Edge(EdgeIndex2 + 1)
            Next
            EdgeCount = EdgeCount - 1
        
        Else
    
            '边界不存在，添加到集合
            ReDim Preserve Edge(EdgeCount)
            Set Edge(EdgeCount) = Selection.Item(1).Value
            EdgeCount = EdgeCount + 1
        
        End If
    
        '选中所有已选择的边界
        Selection.Clear
        For EdgeIndex = 0 To EdgeCount - 1
            Selection.Add Edge(EdgeIndex)
        Next
    
        '询问用户选择是否结束
        OtherEdgeAnswer = MsgBox("还要选取其它边界吗？", vbYesNoCancel + vbInformation, "圆角边界定义")
        If (OtherEdgeAnswer = vbCancel) Then Exit Sub
        If (OtherEdgeAnswer = vbNo) Then AllEdgesHaveBeenSelected = True
    Loop
    
    '为已选边界创建圆角
    Set Fillet = oSF.AddNewEdgeFilletWithConstantRadius(Edge(0), 1, 5)
    Fillet.EdgePropagation = 1
    For EdgeIndex = 1 To EdgeCount - 1
        Fillet.AddObjectToFillet Edge(EdgeIndex)
    Next
    Selection.Clear
    oPart.Update

End Sub