Speed up 'Component Activation State' parameter setting 1

[Arpad_Jacso]

Hi,

I have the code below, which loop through the products of an assembly, and places their specific name into an array depending on the activation state value. (If deactivated, then it starts with a black filled dot). My problem is it takes too much time, I have an assembly with only 26 products, and it takes more than 23seconds to fill the array. Is there any way to speed it up?

Sub CATMain()

On Error Resume Next
If Right(CATIA.ActiveDocument.FullName, 10) <> "CATProduct" Then
MsgBox "Open a product!"
Exit Sub
End If

Set parameters2 = CATIA.ActiveDocument.Product.ReferenceProduct.Parameters

For i = 1 To CATIA.ActiveDocument.Product.Products.Count

Fparam = CATIA.ActiveDocument.Product.name & "\" & CATIA.ActiveDocument.Product.Products.Item(i).name & "\Component Activation State"
Set fParameter = parameters2.Item(Fparam)
oName = CATIA.ActiveDocument.Product.Products.Item(i).PartNumber & " " & CATIA.ActiveDocument.Product.Products.Item(i).name
If fParameter.Value = "False" Then
ActProducts(i) = "• " & oName
Else
ActProducts(i) = oName
End If

Next

.....

End Sub

 

[kantoku]

Hi Arpad_Jacso.

Searching from Parameters is more efficient if you use SubList.
This is 10 years ago, but this is very helpful.
Link

We have only performed simple tests, but we expect that this will significantly reduce execution time.

'vba
Option Explicit

Const PARAM_NAME = "Component Activation State"

Sub CATMain()
    
    'doc
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    'type check
    If Not typename(doc) = "ProductDocument" Then
        MsgBox "Open a CATProduct"
        Exit Sub
    End If
    
    'get Products
    Dim topProd As Product
    Set topProd = doc.Product
    
    Dim prods As Products
    Set prods = topProd.Products
    
    'get Parameter
    Dim lst As Collection
    Set lst = New Collection
    
    Dim prod As Product
    Dim prms As Parameters
    Dim prm As Parameter
    Dim info As String
    
    For Each prod In prods
        On Error Resume Next
        
        Set prms = topProd.Parameters.SubList(prod, False)
        Set prm = prms.Item(PARAM_NAME)
        
        On Error GoTo 0
        
        If prm Is Nothing Then GoTo continue
        
        info = prod.PartNumber & " " & _
               prod.Name
        
        If prm.Value Then
            lst.Add info
        Else
            lst.Add "? " & info
        End If
        
continue:
    Next
    
    'result
    If lst.Count < 1 Then
        MsgBox "Failed to get information"
        Exit Sub
    End If
    
    MsgBox "-- Done --" & vbCrLf & _
        Join(list2ary(lst), vbCrLf)

End Sub

Private Function list2ary( _
    ByVal lst As Collection) As Variant
    
    Dim ary() As Variant
    ReDim ary(lst.Count - 1)
    
    Dim i As Long
    For i = 1 To lst.Count
        ary(i - 1) = lst(i)
    Next
    
    list2ary = ary
    
End Function

 

[kantoku]

sorry.
Because it was created in a Japanese environment

・・・
        Else
            lst.Add "? " & info
        End If
・・・

Is garbled. Please correct.

 

[Arpad_Jacso]

Perfect, the correction is unnecessary, I got the idea.
Thank you very much!