functions.bas

CATIA二次开发

Attribute VB_Name = "functions"
Option Explicit
Option Base 1

'参考截面元素数数组
Public ProfileElement() As Object

'参考截面数量
Public ProfileCount As Integer

'拉伸方向元素
Public DirElement As Object

'是否反方向拉伸标记
Public bReverseDir As Boolean

'拉伸长度
Public Limit1 As Double, Limit2 As Double

'预览元素
Private PreviewElement As HybridShapeExtrude

'设定拉伸长度
Sub SetLimit()
    
    '若设定了反方向拉伸的标志，则交换两个拉伸长度
    If bReverseDir Then
        Limit1 = Val(Form1.txtLimit2.Text)
        Limit2 = Val(Form1.txtLimit1.Text)
    Else
        Limit1 = Val(Form1.txtLimit1.Text)
        Limit2 = Val(Form1.txtLimit2.Text)
    End If
    
End Sub

'选择参考截面
Sub SelProfile()
    
    Dim InputObjectType(0 To 0), Status
    Dim Selection 'As Selection
    Dim SelIndex As Integer
    Set Selection = oPartDoc.Selection
    
    '选择参考截面 多选
    InputObjectType(0) = "MonoDim"
    Status = Selection.SelectElement3 _
        (InputObjectType, "请选择参考截面（按ESC取消）", True, CATMultiSelTriggWhenSelPerf, False)
    
    '把用户选中的元素加入到参考截面元素数组
    If Status = "Normal" Then
        ProfileCount = Selection.Count
        ReDim ProfileElement(ProfileCount)
        For SelIndex = 1 To ProfileCount
            Set ProfileElement(SelIndex) = Selection.Item(SelIndex).Value
        Next
    End If
    
    '清空选择集
    Selection.Clear

End Sub

'选择拉伸方向
Sub SelDir()
    
    Dim InputObjectType(0 To 1), Status
    Dim Selection 'As Selection
    Set Selection = oPartDoc.Selection
    
    '选择拉伸方向
    InputObjectType(0) = "RectilinearMonoDimInfinite"
    InputObjectType(1) = "PlanarBiDimInfinite"
    Status = Selection.SelectElement2(InputObjectType, "请选择拉伸方向（按ESC取消）", True)
    
    '设定拉伸方向元素
    If Status = "Normal" Then
        Set DirElement = Selection.Item(1).Value
    End If
    
    '清空选择集
    Selection.Clear

End Sub

'预览图形
Sub DoPreview()
    
    Dim refDirReference As Reference, refDir As HybridShapeDirection
    Dim refProfile As Reference
    Dim Selection As Selection, visPro
    
    '设定错误控制，以便允许用户修改选择错误
    On Error Resume Next
    
    '检查预览的条件
    If Not (DirElement Is Nothing) And ProfileCount > 0 Then
        
        '删除先前的预览结果，设定拉伸长度
        DelPreview
        SetLimit
        
        '创建参考元素
        Set refDirReference = oPart.CreateReferenceFromObject(DirElement)
        Set refDir = oHSF.AddNewDirection(refDirReference)
        Set refProfile = oPart.CreateReferenceFromObject(ProfileElement(1))
        
        '创建预览元素
        Set oHBody = AddHBody("PreviewTmp")
        Set PreviewElement = oHSF.AddNewExtrude(refProfile, Limit1, Limit2, refDir)
        oHBody.AppendHybridShape PreviewElement
        
        '更新零件文档
        oPart.Update
    
    End If
    On Error GoTo 0

End Sub

'删除预览图形
Sub DelPreview()
    
    Dim Selection As Selection
    
    On Error Resume Next
    
    '预览图形存在才进行删除
    If Not (PreviewElement Is Nothing) Then
        Set Selection = oPartDoc.Selection
        Set oHBody = oHBodies.GetItem("PreviewTmp")
        Selection.Clear
        Selection.Add oHBody
        Selection.Add PreviewElement
        Selection.Delete
    End If
    
End Sub

'拉伸所选的元素
Sub DoExtrude()
    
    Dim refDirReference As Reference, refDir As HybridShapeDirection
    Dim refProfile As Reference, oExtrude As HybridShapeExtrude
    Dim i As Integer
    
    On Error Resume Next
    
    '设定拉伸长度，创建几何图形集以便放置拉伸元素
    SetLimit
    Set oHBody = AddHBody("Extrude")
    
    '根据所选元素数量创建循环
    For i = 1 To ProfileCount
        
        '创建参考元素
        Set refDirReference = oPart.CreateReferenceFromObject(DirElement)
        Set refDir = oHSF.AddNewDirection(refDirReference)
        Set refProfile = oPart.CreateReferenceFromObject(ProfileElement(i))
        
        '创建拉伸
        Set oExtrude = oHSF.AddNewExtrude(refProfile, Limit1, Limit2, refDir)
        oHBody.AppendHybridShape oExtrude
    
    Next
    
    '更新文档
    oPart.Update

End Sub