鱼眼灯花.bas

CATIA二次开发

Attribute VB_Name = "鱼眼"
Option Explicit

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

Dim DHHeightH As Double
Dim DHWidthH As Double
Dim DHCountH As Integer

Dim BaseSurf          As Object
Dim BaseSurfOffset    As Object
Dim BaseSurfMidOffset As Object

Dim BaseCurve  As Object
Dim GuideCurve As Object

Dim BaseCurveH  As Object
Dim GuideCurveH As Object

Dim StPt1 As Object
Dim StPt2 As Object

Dim StPt1H As Object
Dim StPt2H As Object

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

Dim IntCurveLowM()  As HybridShapeIntersection
Dim IntCurveHighM() As HybridShapeIntersection

Dim IntCurveLowH()  As HybridShapeIntersection
Dim IntCurveHighH() As HybridShapeIntersection

Dim IntCurveLowMH()  As HybridShapeIntersection
Dim IntCurveHighMH() As HybridShapeIntersection

Dim IntPtLow()  As HybridShapeIntersection
Dim IntPtMid()  As HybridShapeIntersection
Dim IntPtMidH() As HybridShapeIntersection
Dim IntPtHigh() As HybridShapeIntersection

Dim CircleCurve()  As HybridShapeCircle
Dim CircleCurveH() As HybridShapeCircle

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

Public DefineFinished_Step1 As Boolean
Public DefineFinished_Step2 As Boolean
'--------------------------------------------

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

End Sub

'选择参考元素
Sub SetRef()
    
    Dim DefineBaseSurfFinished As Boolean
    Dim DefineBaseCurveFinished As Boolean
    Dim DefineGuideCurveFinished As Boolean
    Dim DefineStPt1Finished As Boolean
    Dim DefineStPt2Finished As Boolean
    
    Dim InputObjectType()
    Dim Selection As Object
    Dim Status
    
    DefineFinished_Step1 = False
    
    
    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_Step1 = True
    
    
End Sub

Sub SetRefH()
    
    Dim DefineBaseSurfFinished As Boolean
    Dim DefineBaseCurveFinished As Boolean
    Dim DefineGuideCurveFinished As Boolean
    Dim DefineStPt1Finished As Boolean
    Dim DefineStPt2Finished As Boolean
    
    Dim InputObjectType()
    Dim Selection As Object
    Dim Status
    
    DefineFinished_Step2 = False
    
    Set Selection = oPartDoc.Selection
    
    frmDHGen.txtBaseCurveH.SetFocus
    frmDHGen.txtBaseCurveH.SelStart = 0
    frmDHGen.txtBaseCurveH.SelLength = Len(frmDHGen.txtBaseCurveH.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 BaseCurveH = Selection.Item(1).Value
                Selection.Clear
                DefineBaseCurveFinished = True
        
        Else
            Exit Sub
        End If
        
    Loop
    
    frmDHGen.txtBaseCurveH.Text = BaseCurveH.Name
    
    frmDHGen.txtGuideCurveH.SetFocus
    frmDHGen.txtGuideCurveH.SelStart = 0
    frmDHGen.txtGuideCurveH.SelLength = Len(frmDHGen.txtGuideCurveH.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 GuideCurveH = Selection.Item(1).Value
                Selection.Clear
                DefineGuideCurveFinished = True
        
        Else
            Exit Sub
        End If