hdwdlnd
Aerospace
- Sep 1, 2009
- 16
I know there are some previous threads that are similar to this that have been closed but I thought I would post the wonky VBA script I have been using for this that is somewhat hit or miss. It mostly works but sometimes behaves a little strange by de-activating the first child node of some of the parent nodes highlighted. I use this to toggle activation on part products, products, and components. If anyone can clean this up or make it work better I would appreciate any input that can be provided. Forgive me for the extra commented garbage and probably a lot of declarations that are not needed...
Code:
Sub CATMain()
'On Error GoTo PartCheck
Set CDoc = CATIA.ActiveDocument
Dim Sel1 As Selection
Set Sel1 = CDoc.Selection
Dim oRootProd As product
Set oRootProd = CATIA.ActiveDocument.product
Dim InstName As String
Dim FNamePth As String
Dim fullpath() As String
ReDim fullpath(100)
Dim prodArr() As product
Dim prodsArr() As Products
Dim objPrd As Object
Dim reachroot As Variant
Dim checkParent As String
Dim m As Integer
Dim Test3 As String
Dim testname As String
Dim x As Integer
Dim oParam As Parameter
Dim TopLevelName As String
TopLevelName = CATIA.ActiveDocument.Name
TopLevelName = Left(TopLevelName, Len(TopLevelName) - 11)
icount = CATIA.ActiveDocument.Selection.Count2
Set TestTopProd = CATIA.ActiveDocument.product
TopProdPN = TestTopProd.PartNumber
If TopLevelName <> TopProdPN Then
TestTopProd.PartNumber = TopLevelName
End If
Dim state As String
Dim isPart As Integer
Dim TestProd As product
For n = 1 To icount
Set objPrd = Sel1.item(n).LeafProduct
isPart = objPrd.Products.count
fullpath(0) = objPrd.Name
'test3 = objPrd.Parent.Name
'test3 = Sel1.Item(n).Name
'Set testprod = objPrd.Products.Item(test3)
'test3 = testprod.PartNumber
m = 1
x = 0
While Not reachroot
Set objPrd = objPrd.Parent
fullpath(m) = objPrd.Name '& "\" & fullpath
checkParent = ""
checkParent = objPrd.Parent.Name
If checkParent Like "*.CATProduct*" Then
checkParent = Left(checkParent, Len(checkParent) - 11)
ElseIf checkParent Like "*.CATPart*" Then
checkParent = Left(checkParent, Len(checkParent) - 8)
End If
fullpath(m) = checkParent
If fullpath(m) <> "Products" Then
testname = fullpath(m) & "\" & testname
m = m + 1
End If
If checkParent = TopLevelName Then reachroot = True
Wend
testname = testname & fullpath(0)
m = m - 1
reachroot = False
ReDim prodArr(m)
ReDim prodsArr(m - 1)
Dim product1 As product
Set product1 = CDoc.product
Dim products1 As Products
Set products1 = product1.Products
If m = 1 Then GoTo OneDegree
Set prodArr(m) = products1.item(CStr(fullpath(m - 1)))
For i = m - 1 To 1 Step -1
Set prodsArr(i) = prodArr(m - x).Products
'testname = prodArr(m - x).Name
Set prodArr(i) = prodsArr(i).item(CStr(fullpath(i - 1)))
'testname = prodArr(i).Name
x = x + 1
Next
i = i + 1
GoTo nthDegree
nthDegree:
Dim prodname As String
prodname = prodArr(i).Name
prodname = CStr(fullpath(0))
If isPart = 0 Then
prodArr(i).ApplyWorkMode DESIGN_MODE
End If
'state = prodArr(i).Parameters.Item("Component Activation State").ValueAsString 'testname & "\Component Activation State")
'MsgBox (state)
'testname = prodArr(i).Parameters.Item("Component Activation State").ValueAsString
'testname = prodArr(i).Name
'Set oParam = prodsArr(i).Item(CStr(fullpath(0))).Parameters.Item(testname & "\Component Activation State")
state = ""
state = prodArr(i).Parameters.item("Component Activation State").ValueAsString
'Set oParam = prodArr(i).Parameters.Item("Component Activation State")
'Set oParam = prodArr(m - x - 1).Products.Item(prodname).Parameters.Item(testname & "\Component Activation State")
'Set oParam = prodArr(i).Parameters.Item(testname & "\Component Activation State")
'state = oParam.ValueAsString
If state = "true" Then
'testname = prodArr(I).Name
'testname = prodArr(I + 1).Name
'testname = prodArr(I).Parameters.Item("Component Activation State")
prodArr(i).Parameters.item("Component Activation State").ValuateFromString ("false") ' = "false"
'Set oParam = prodArr(I).Parameters.Item(testname & "\Component Activation State")
'oParam.ValuateFromString ("false")
'prodArr(I).ReferenceProduct.Parameters.Item("Component Activation State").ValuateFromString ("false") ' = "false"
Else
'testname = prodArr(I).Name
'testname = prodArr(I + 1).Name
'prodArr(I).DesactivateDefaultShape
prodArr(i).Parameters.item("Component Activation State").ValuateFromString ("true") ' = "true"
'prodArr(I).Parameters.Item("Component Activation State").ValuateFromString ("true") ' = "true"
'Set oParam = prodArr(I).Parameters.Item(testname & "\Component Activation State")
'oParam.ValuateFromString ("true")
End If
GoTo NextItem
OneDegree:
If isPart = 0 Then
oRootProd.Products.item(fullpath(0)).ApplyWorkMode DESIGN_MODE
End If
state = oRootProd.Products.item(fullpath(0)).Name
Set oParam = oRootProd.Products.item(fullpath(0)).Parameters.item(oRootProd.Name & "\" & oRootProd.Products.item(fullpath(0)).Name & "\Component Activation State")
state = oParam.ValueAsString
If state = "true" Then
oParam.ValuateFromString ("false")
Else
'MsgBox (objPrd2.Name)
oParam.ValuateFromString ("true")
'oRootProd.Products.Item(fullpath(0)).Parameters.Item("Component Activation State").Value = "true"
End If
'Dim product2 As Product
'Set product2 = products1.Item(InstName)
'Set Nothing1 = products1.ReplaceComponent(product2, FNamePth, True)
'product2.PartNumber = "Test i"
NextItem:
testname = ""
state = ""
Next n
End Sub