Примеры работающего кода

[MisterX]

Коллеги, если есть возможность, предлагаю выкладывать сюда функционально законченные и работающие куски кода, которыми не жалко поделиться.

[MisterX]

Я в свою очередь в благодарность за помощь здесь:

http://www.catiaforum.ru/forum/viewtopic.php?f=140&t=1256

выкладываю код, выдирающий из продукта, в котором создана труба в среде Tubing Design, параметры гиба трубы.
В отличие от КАТИЙНОГО кода в хэлпе - этот полный и работает.

Для корректной работы перед запуском кода необходимо выделить в дереве продукт, содержащий LineID

Код: Выделить всё

Public Sub ExtractBendingData()
   
    Const Inch = 25.4
   
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
   
    Dim sel As Selection
    Set sel = doc.Selection
   
    'SelectElement2 - ЗАРАЗА НЕ РАБОТАЕТ
    'sel.Clear
    'MsgBox "Выберите в дереве продукт, содержащий LineID."
    'Dim Status As Variant
    'Status = CallByName(sel, SelectElement2, VbMethod, "Product", "Выберите в дереве продукт, содержащий LineID...", False)
   
    'Define proper workbench
    Dim objCATIAV5ArrWorkbench0 As Workbench
    Set objCATIAV5ArrWorkbench0 = doc.GetWorkbench("ArrWorkbench")
   
    ' Find from the selection list, objects that conform to the CATIAArrSystemLineProduct interface.
    'On Error Resume Next
   
    Dim objSysLineProduct As ArrSystemLineProduct
   
    On Error Resume Next
    Set objSysLineProduct = sel.FindObject("CATIAArrSystemLineProduct")
    'MsgBox Err.Number
    If Err.Number = -2147467259 Then
        MsgRezult = MsgBox("Не был выделен продукт, содержащий Line ID.", , "Ошибка!")
        Err.Clear
        Exit Sub
    End If
       
    ' Get the count of subproducts, actual subproduct (methods of CATIArrSystemLineProduct interface)
    ' In fact you get number of LineIDs used to create this tube (tube system)
    Dim intNumOfSubProducts As Integer
    intNumOfSubProducts = objSysLineProduct.GetSubProductsCount("CATIAArrBendableString")
   
    'This Macro used to get data from whole system of LineIDs (if more than one)
    'or from the singular LineID.
       
    'Start to get the bending data information form ArrBendableString object
   
    Dim objBendableString As Variant    'Generally type should be - ArrBendableString
    Dim NumOfSegments As Variant
    Dim dblSegmentDataStraight(14) As Variant
    Dim dblSegmentDataBended(14) As Variant
    Dim LineIDNmb, SegNmb As Integer
   
    For LineIDNmb = 1 To intNumOfSubProducts
   
        Set objBendableString = objSysLineProduct.GetSubItem(1)
 
        'Get Instance Name of the ArrBendableString object
        objBendableString.InstanceName
       
        'Get number of Segments
        NumOfSegments = objBendableString.GetNumOfSegments

        For SegNmb = 1 To NumOfSegments
            'EXTRACT BENDING DATA
            'dblSegmentDataStraight - Array to store data of one segment. In next cycle iteration it will be re-filled,
            'so there's need to store or output this data isdide the cycle
            objBendableString.GetSegmentData SegNmb, dblSegmentDataStraight
            If SegNmb < NumOfSegments Then
                objBendableString.GetSegmentData (SegNmb + 1), dblSegmentDataBended
            Else
                For K = 0 To 14
                    dblSegmentDataBended(K) = 0
                Next
            End If
        Next
    Next

' The data can be interpreted as follows
    'dblStrXCoord = dblSegmentData(0)
    'dblStrYCoord = dblSegmentData(1)
    'dblStrZCoord = dblSegmentData(2)

    'dblEndXCoord = dblSegmentData(3)
    'dblEndYCoord = dblSegmentData(4)
    'dblEndZCoord = dblSegmentData(5)

    '//Valid only if Radius > 0
    'dblBendNodeXCoord = dblSegmentData(6)
    'dblBendNodeYCoord = dblSegmentData(7)
    'dblBendNodeZCoord = dblSegmentData(8)

    '//Valid only if Radius > 0
    'dblBendRadius = dblSegmentData(9)
    'dblBendAngle = dblSegmentData(10)

    'dblRotationAngle = dblSegmentData(11)
    'dblSlopeAngle = dblSegmentData(12)

    'dblLinearSegLen = dblSegmentData(13)
    '//Arc Len valid only if Radius > 0
    'dblArcLen = dblSegmentData(14)

End Sub

[RIMs]

сумасшедшая идея, еще десяток программ и в этом лесу не разгрестись.