直条灯花.bas

CATIA二次开发

Attribute VB_Name = "灯花"
Option Explicit

Dim DHHeight As Double
Dim DHWidth As Double
Dim DHCount As Integer

Dim BaseCurve As Object
Dim GuideCurve As Object
Dim BaseSurf As Object
Dim BaseSurfOffset As Object
Dim StPt1 As Object
Dim StPt2 As Object

Dim IntCurveLow() As HybridShapeIntersection
Dim IntCurveHigh() As HybridShapeIntersection

Dim relations As Object
Dim Formula As Object
Dim parameters As Object
Dim Parm  As Object

Public DefineFinished As Boolean

'设定工作文档
Sub Init()
    
    InitCATIAPart False
    
    ' Init working knowledge parameters
    Set parameters = oPart.parameters
    ' Working Parm object
    
    ' Init working knowledge relations
    Set relations = oPart.relations
    ' Working Formula object

End Sub

'选择参考元素
Sub SetRef()
    
    Dim DefineBaseSurfFinished As Boolean
    Dim DefineBaseCurveFinished As Boolean
    Dim DefineGuideCurveFinished As Boolean
    Dim DefineStPt1Finished As Boolean
    Dim DefineStPt2Finished As Boolean
    
    DefineFinished = False
    
    Dim InputObjectType()
    Dim Selection As Object
    Dim Status
    
    Set Selection = oPartDoc.Selection
    
    frmDHGen.txtBaseSurf.SetFocus
    frmDHGen.txtBaseSurf.SelStart = 0
    frmDHGen.txtBaseSurf.SelLength = Len(frmDHGen.txtBaseSurf.Text)
    
    Do While Not DefineBaseSurfFinished
    
        ReDim InputObjectType(0)
        InputObjectType(0) = "HybridShapeSurfaceExplicit"
        
        Status = Selection.SelectElement2(InputObjectType, "请选择一个基面", True)
        
        If (Status = "Cancel") Then
            Exit Sub
        ElseIf (Status = "Redo") Then
'           We do nothing: Redo has no meaning in this context
        ElseIf (Status = "Undo") Then
            Exit Sub
        ElseIf (Status <> "Redo") Then
                
                Set BaseSurf = Selection.Item(1).Value
                Selection.Clear
                DefineBaseSurfFinished = True
        
        Else
            Exit Sub
        End If
        
    Loop
    
    frmDHGen.txtBaseSurf.Text = BaseSurf.Name
    
    frmDHGen.txtBaseCurve.SetFocus
    frmDHGen.txtBaseCurve.SelStart = 0
    frmDHGen.txtBaseCurve.SelLength = Len(frmDHGen.txtBaseCurve.Text)
    
    Do While Not DefineBaseCurveFinished
    
        ReDim InputObjectType(0)
        InputObjectType(0) = "HybridShapeCurveExplicit"
        
        Status = Selection.SelectElement2(InputObjectType, "请选择一条基线（等分线）", True)
        
        If (Status = "Cancel") Then
            Exit Sub
        ElseIf (Status = "Redo") Then
'           We do nothing: Redo has no meaning in this context
        ElseIf (Status = "Undo") Then
            Exit Sub
        ElseIf (Status <> "Redo") Then
                
                Set BaseCurve = Selection.Item(1).Value
                Selection.Clear
                DefineBaseCurveFinished = True
        
        Else
            Exit Sub
        End If
        
    Loop
    
    frmDHGen.txtBaseCurve.Text = BaseCurve.Name
    
    frmDHGen.txtGuideCurve.SetFocus
    frmDHGen.txtGuideCurve.SelStart = 0
    frmDHGen.txtGuideCurve.SelLength = Len(frmDHGen.txtGuideCurve.Text)
    
    Do While Not DefineGuideCurveFinished
    
        ReDim InputObjectType(0)
        InputObjectType(0) = "HybridShapeCurveExplicit"
        
        Status = Selection.SelectElement2(InputObjectType, "请选择一条脊线（对齐线）", True)
        
        If (Status = "Cancel") Then
            Exit Sub
        ElseIf (Status = "Redo") Then
'           We do nothing: Redo has no meaning in this context
        ElseIf (Status = "Undo") Then
            Exit Sub
        ElseIf (Status <> "Redo") Then
                
                Set GuideCurve = Selection.Item(1).Value
                Selection.Clear
                DefineGuideCurveFinished = True
        
        Else
            Exit Sub
        End If
        
    Loop
    
    frmDHGen.txtGuideCurve.Text = GuideCurve.Name
    
    frmDHGen.txtStPt1.SetFocus
    frmDHGen.txtStPt1.SelStart = 0
    frmDHGen.txtStPt1.SelLength = Len(frmDHGen.txtStPt1.Text)
    
    Do While Not DefineStPt1Finished
    
        ReDim InputObjectType(1)
        InputObjectType(0) = "Point"
        InputObjectType(1) = "Vertex"
        
        Status = Selection.SelectElement2(InputObjectType, "请选择起始点1(底边起始点)", True)
        
        If (Status = "Cancel") Then
            Exit Sub
        ElseIf (Status = "Redo") Then
'           We do nothing: Redo has no meaning in this context
        ElseIf (Status = "Undo") Then
            Exit Sub
        ElseIf (Status <> "Redo") Then
                
                Set StPt1 = Selection.Item(1).Value
                Selection.Clear
                DefineStPt1Finished = True
        
        Else
            Exit Sub
        End If
        
    Loop
    
    frmDHGen.txtStPt1.Text = StPt1.Name
    
    frmDHGen.txtStPt2.SetFocus
    frmDHGen.txtStPt2.SelStart = 0
    frmDHGen.txtStPt2.SelLength = Len(frmDHGen.txtStPt2.Text)
    
    Do While Not DefineStPt2Finished
    
        ReDim InputObjectType(1)
        InputObjectType(0) = "Point"
        InputObjectType(1) = "Vertex"
        
        Status = Selection.SelectElement2(InputObjectType, "请选择起始点2(顶边起始点)", True)
        
        If (Status = "Cancel") Then
            Exit Sub
        ElseIf (Status = "Redo") Then
'           We do nothing: Redo has no meaning in this context
        ElseIf (Status = "Undo") Then
            Exit Sub
        ElseIf (Status <> "Redo") Then
                
                Set StPt2 = Selection.Item(1).Value
                Selection.Clear
                DefineStPt2Finished = True
        
        Else
            Exit Sub
        End If
        
    Loop
    
    frmDHGen.txtStPt2.Text = StPt2.Name
    
    DefineFinished = True
    
End Sub

'设定参数
Sub SetPar()
    
    ' --------------------------------------------------------------
    ' 设定参数
    ' --------------------------------------------------------------
    
    DHHeight = Val(frmDHGen.txtHeight.Text)
    DHWidth = Val(frmDHGen.txtWidth.Text)
    DHCount = Val(frmDHGen.txtCount.Text)
    
    
    ' Set Parameters for stair generation
    Set Parm = parameters.CreateDimension("Height", "LENGTH", DHHeight)
    Set Parm = parameters.CreateDimension("WidthLow", "LENGTH", DHWidth)
    Set Parm = parameters.CreateDimension("WidthHigh", "LENGTH", DHWidth)
    Set Formula = relations.CreateFormula("WidthHighF", "", Parm, "WidthLow")
    Set Parm = parameters.CreateDimension("inc", "LENGTH", 0#)
    
    oPart.Update

End Sub

'创建基础元素
Sub CreateBaseElement()
    
    ' Adding an OpenBody
    Set oHBody = AddHBody("基础元素")
    HideShow oHBody
    
    ' Create offset surface
    Dim oBaseSurfOffset As Object
    Set oBaseSurfOffset = oHSF.AddNewOffset(BaseSurf, 2, 0, 0)
    oHBody.AppendHybridShape oBaseSurfOffset
    oBaseSurfOffset.Name = "BaseSurfOffset"
    ' Create formula defining
    Set Formula = relations.CreateFormula("BaseSurfOffsetF", "", oBaseSurfOffset.OffsetValue, "Height")
    
    Set BaseSurfOffset = oPart.CreateReferenceFromObject(oBaseSurfOffset)
    
    oPart.Update
    
End Sub

'生成交线
Sub CreateIntersection()
    
    Dim initPoint As HybridShapePointOnCurve
    Dim initPlane As Object
    Dim refPt As Reference
    Dim RefGuide As Reference
    Dim refPlane As Reference
    Dim refSuf As Reference
    
    Dim i As Integer
    
    ' --------------------------------------------------------------
    ' 创建等分点
    ' --------------------------------------------------------------
    ' Create Low Points
    Set oHBody = AddHBody("边界底部")
'    HideShow oHBody
    
    ReDim IntCurveLow(DHCount + 1)
    ReDim IntCurveHigh(DHCount)
    
    Set refPt = StPt1
    Set RefGuide = GuideCurve
    
    For i = 1 To DHCount + 1
        
        Set initPoint = oHSF.AddNewPointOnCurveWithReferenceFromDistance(BaseCurve, refPt, 2, 0)
        'oHBody.AppendHybridShape initPoint
        Set Formula = relations.CreateFormula("pF_" & Trim(Str(i)), "", initPoint.Offset, "WidthLow+" & Str(i) & "*inc")
        initPoint.Name = "initPointLow_" & Trim(Str(i))
        
        Set refPt = oPart.CreateReferenceFromObject(initPoint)
        Set initPlane = oHSF.AddNewPlaneNormal(RefGuide, refPt)
        'oHBody.AppendHybridShape initPlane
        initPoint.Name = "initPlaneLow_" & Trim(Str(i))
        
        Set refPlane = oPart.CreateReferenceFromObject(initPlane)
        Set IntCurveLow(i) = oHSF.AddNewIntersection(BaseSurf, refPlane)
        oHBody.AppendHybridShape IntCurveLow(i)
        IntCurveLow(i).Name = "IntCurveLow_" & Trim(Str(i))
    
    Next
    
    ' Create Hight Points
    Set oHBody = AddHBody("边界顶部")
    HideShow oHBody
    
    Set refPt = StPt2
    Set initPoint = oHSF.AddNewPointOnCurveWithReferenceFromDistance(BaseCurve, refPt, 1, 0)
    oHBody.AppendHybridShape initPoint
    Set Formula = relations.CreateFormula("pF_" & Trim(Str(i)), "", initPoint.Offset, "WidthHigh/2")
    initPoint.Name = "initPointHighStart"
    HideShow initPoint
    
    Set refPt = oPart.CreateReferenceFromObject(initPoint)
    Set refSuf = BaseSurfOffset
    
    For i = 1 To DHCount
        
        Set initPoint = oHSF.AddNewPointOnCurveWithReferenceFromDistance(BaseCurve, refPt, 2, 0)
        'oHBody.AppendHybridShape initPoint
        initPoint.Name = "initPointHigh_" & Trim(Str(i))
        Set Formula = relations.CreateFormula("pF_" & Trim(Str(i)), "", initPoint.Offset, "WidthHigh+" & Str(i) & "*inc+inc/2")
        
        Set refPt = oPart.CreateReferenceFromObject(initPoint)
        Set initPlane = oHSF.AddNewPlaneNormal(RefGuide, refPt)
        'oHBody.AppendHybridShape initPlane
        initPoint.Name = "initPlaneHigh_" & Trim(Str(i))
        
        Set refPlane = oPart.CreateReferenceFromObject(initPlane)
        Set IntCurveHigh(i) = oHSF.AddNewIntersection(refSuf, refPlane)
        oHBody.AppendHybridShape IntCurveHigh(i)
        IntCurveHigh(i).Name = "IntCurveHigh_" & Trim(Str(i))
    
    Next
        
    oPart.Update
    
End Sub

'生成圆弧曲面
Sub CreateCircleSurf()
    
    Dim refCurve1 As Reference
    Dim refCurve2 As Reference
    Dim refCurve3 As Reference
    Dim DHSuf As HybridShapeSweepCircle
    Dim i As Integer
    
    Set oHBody = AddHBody("圆形灯花面")
    
    For i = 1 To DHCount

        Set refCurve1 = oPart.CreateReferenceFromObject(IntCurveLow(i))
        Set refCurve2 = oPart.CreateReferenceFromObject(IntCurveHigh(i))
        Set refCurve3 = oPart.CreateReferenceFromObject(IntCurveLow(i + 1))
        Set DHSuf = oHSF.AddNewSweepCircle(refCurve1)
        DHSuf.Mode = 2
        DHSuf.SecondGuideCrv = refCurve2
        DHSuf.ThirdGuideCrv = refCurve3
        
        oHBody.AppendHybridShape DHSuf
        DHSuf.Name = "SweptSuf_" & Trim(Str(i))

    Next
    
    oPart.Update

End Sub

'生成圆心线
Sub CreateCircleCenter()
    
    Dim initPoint As HybridShapePointOnCurve
    Dim initPlane As Object
    Dim IntCurve As Object
    Dim refPt As Reference
    Dim refPlane As Reference
    Dim i As Integer
    
    Set oHBody = AddHBody("圆形灯花面圆心线")
    
    ' Create offset surface
    Dim oBaseSurfOffset As Object
    Set oBaseSurfOffset = oHSF.AddNewOffset(BaseSurf, 2, 1, 0)
    oHBody.AppendHybridShape oBaseSurfOffset
    oBaseSurfOffset.Name = "CenterSurfOffset"
    ' Create formula defining
    Set Formula = relations.CreateFormula("CenterSurfOffsetF", "", oBaseSurfOffset.OffsetValue, "(4 * Height * Height + WidthLow * WidthLow) / (8 * Height) - Height")
    
    Dim CenterSurf As Reference
    Set CenterSurf = oPart.CreateReferenceFromObject(oBaseSurfOffset)
    
    Set refPt = StPt1
    Set initPoint = oHSF.AddNewPointOnCurveWithReferenceFromDistance(BaseCurve, refPt, 1, 0)
    oHBody.AppendHybridShape initPoint
    Set Formula = relations.CreateFormula("pF_" & Trim(Str(i)), "", initPoint.Offset, "WidthHigh/2")
    initPoint.Name = "CenterPointHighStart"
    HideShow initPoint
    Set refPt = oPart.CreateReferenceFromObject(initPoint)
    
    For i = 1 To DHCount

        Set initPoint = oHSF.AddNewPointOnCurveWithReferenceFromDistance(BaseCurve, refPt, 2, 0)
        oHBody.AppendHybridShape initPoint
        Set Formula = relations.CreateFormula("pF_" & Trim(Str(i)), "", initPoint.Offset, "WidthLow")
        initPoint.Name = "initPointLow_" & Trim(Str(i))
        HideShow initPoint
        
        Set refPt = oPart.CreateReferenceFromObject(initPoint)
        Set initPlane = oHSF.AddNewPlaneNormal(GuideCurve, refPt)
        oHBody.AppendHybridShape initPlane
        initPoint.Name = "initPlaneLow_" & Trim(Str(i))
        HideShow initPlane
        
        Set refPlane = oPart.CreateReferenceFromObject(initPlane)
        Set IntCurve = oHSF.AddNewIntersection(CenterSurf, refPlane)
        oHBody.AppendHybridShape IntCurve
        IntCurve.Name = "IntCurveLow_" & Trim(Str(i))
    
    Next
    
    oPart.Update

End Sub

'生成三角曲面
Sub CreateTriSurf()
    
    Dim refCurve1 As Reference
    Dim refCurve2 As Reference
    Dim refCurve3 As Reference
    Dim DHSuf As HybridShapeSweepLine
    Dim i As Integer
    
    Set oHBody = AddHBody("三角形灯花面")
    
    For i = 1 To DHCount

        Set refCurve1 = oPart.CreateReferenceFromObject(IntCurveLow(i))
        Set refCurve2 = oPart.CreateReferenceFromObject(IntCurveHigh(i))
        Set refCurve3 = oPart.CreateReferenceFromObject(IntCurveLow(i + 1))

        Set DHSuf = oHSF.AddNewSweepLine(refCurve1)
        DHSuf.Mode = 1
        DHSuf.SecondGuideCrv = refCurve2
        
        oHBody.AppendHybridShape DHSuf
        DHSuf.Name = "SweptSuf_1_" & Trim(Str(i))
        
        Set DHSuf = oHSF.AddNewSweepLine(refCurve2)
        DHSuf.Mode = 1
        DHSuf.SecondGuideCrv = refCurve3
        
        oHBody.AppendHybridShape DHSuf
        DHSuf.Name = "SweptSuf_2_" & Trim(Str(i))


    Next
    
    oPart.Update

End Sub