Re-Order CATIA Tree 16

[weagan22]

All,

I am working on a macro to re-order the product tree. I first developed a macro that cuts and pastes the each of the components in the right order. This worked great but has the issue of breaking any drawings that are linked to the components. As far as I know the only way to re-order the tree without breaking links is using the "Graph tree Reorder" command. I have had some success pushing keystrokes (sendkeys) into this command to perform the required re-ordering but I am running into an issue as the model gets larger allowing time for the command to open prior to sending keys is proving difficult. I have tried using "Sub Sleep Lib "kernel32"", Application.Wait (Now + TimeValue("00:00:10")), sending the program into a loop for a set period of time, and CATIA.RefreshDisplay = True. All of these pause the macro, but the command doesn't open while the code is paused. Any ideas?

Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
'Declare sleep
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub CATOrder()

Dim selectProducts As Products
Dim Item As Product
Dim i, d, m, k, g As String
Dim prodCnt, pn, currentPos, position, cntr, bs As Integer
Dim continue As Boolean
Dim pastPos() As Integer
Dim timer As Double


On Error GoTo 2
Set selectProducts = CATIA.ActiveDocument.Selection.Item2(1).Value.Products

'Open Excel
Dim Excel As Object
Set Excel = CreateObject("Excel.Application")
Excel.Visible = True
Excel.workbooks.Add

Excel.Cells(1, 1) = "Part Number"
Excel.Cells(1, 2) = "Detail Number"
Excel.Cells(1, 3) = "Instance Name"
Excel.Cells(1, 4) = "ORDER"

Excel.Cells(1, 1).Font.Bold = True
Excel.Cells(1, 2).Font.Bold = True
Excel.Cells(1, 3).Font.Bold = True
Excel.Cells(1, 4).Font.Bold = True
Excel.Cells(1, 4).Interior.ColorIndex = 15
Excel.Cells(1, 1).Borders.LineStyle = xlContinuous
Excel.Cells(1, 2).Borders.LineStyle = xlContinuous
Excel.Cells(1, 3).Borders.LineStyle = xlContinuous
Excel.Cells(1, 3).Borders.LineStyle = xlContinuous


prodCnt = selectProducts.Count
On Error Resume Next
'Input values into excel
i = 1
g = 2
Do While i < prodCnt + 1

Set Item = selectProducts.Item(i)

pn = InStr(Item.PartNumber, "_")
pn = Right(Item.PartNumber, Len(Item.PartNumber) - pn)
pn = Left(pn, Len(pn) - 2)

Excel.Cells(g, 1) = Item.PartNumber
Excel.Cells(g, 2) = pn
Excel.Cells(g, 3) = Item.Name
Excel.Cells(g, 4) = i

Excel.Cells(g, 1).Borders.LineStyle = xlContinuous
Excel.Cells(g, 2).Borders.LineStyle = xlContinuous
Excel.Cells(g, 3).Borders.LineStyle = xlContinuous
Excel.Cells(g, 4).Borders.LineStyle = xlContinuous
Excel.Cells(g, 4).Interior.ColorIndex = 15

g = g + 1
i = i + 1
Loop

'Sort values in Excel
continue = MsgBox("Sort Excel then press 'OK'.", vbOKCancel)

If continue = vbCancel Then
End
End If

CATIA.RefreshDisplay = True
CATIA.StartCommand "Graph tree Reordering"
Sleep 1000

'Application.Wait (Now + TimeValue("00:00:10"))

'timer = Now + 0.0000115
'Do While Now < timer
'bs = bs + 1
'Loop



mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

Application.SendKeys "{TAB}", True
Application.SendKeys "{TAB}", True
Application.SendKeys "{TAB}", True

Excel.Cells(1, 5) = "i"
Excel.Cells(1, 6) = "position"
Excel.Cells(1, 7) = "d"
Excel.Cells(1, 8) = "m"
Excel.Cells(1, 9) = "cntr"

'Sort tree with Graph tree Reordering
i = 1
Do While i < prodCnt + 1

Excel.Cells(i + 1, 5) = i

position = Excel.Cells(i + 1, 4)

k = i - 2
cntr = 0
Do While k >= 0
If pastPos(k) > position Then
cntr = cntr + 1
End If
k = k - 1
Loop

ReDim Preserve pastPos(i - 1)
pastPos(i - 1) = position

d = position + cntr - i + 1

If i = 1 Then
d = d - 1
End If

m = position + cntr - i


Excel.Cells(i + 1, 9) = cntr
Excel.Cells(i + 1, 6) = position
Excel.Cells(i + 1, 7) = d

Do While d > 0
Call arrowDwn
d = d - 1
Loop

Call tabUp


Excel.Cells(i + 1, 8) = m


Do While m > 0
Call moveUp
m = m - 1
Loop

Call tabDwn
i = i + 1
Sleep 200
Loop




closeExcel = MsgBox("Would you like to close Excel?", vbYesNo)
If closeExcel = vbYes Then

Close Excel
Excel.ActiveWorkbook.Close SaveChanges:=False
Excel.Quit
End If

GoTo 1

2:
MsgBox "Select a product before running macro."

Excel.ActiveWorkbook.Close SaveChanges:=False
Excel.Quit

1:
End Sub
Function moveUp()

Application.SendKeys "~"

End Function
Function arrowDwn()

Application.SendKeys "{DOWN}"

End Function
Function tabUp()

Application.SendKeys "{TAB}"

End Function
Function tabDwn()

Application.SendKeys "+{TAB}"

End Function

 

[cilici]

Hello,

I had similar queries from people running on slow computers. Having the same assembly reordered on a more powerful computer was fine.

Now, this message is a warning and the differences between expected and actual result should be minimum therefore you could manually do the missing moves in the tree.

I know that this behavior is not what I intended when developing this app and it should do what was programmed to do but there can be so many particularities in terms of software and hardware.

Calin