Text dotazu:
Prosím o radu jak toto makro upravit abych mohl označit díly v otevřené základní sestavě a následně by se tvořil kusovník v exelu. nyní musím otevřít sestavu kde se jednotlivé party nacházejí a z té se udělat kusovník. to je sice fajn ale potřeboval bych udělat celkový výpis kusů z cele sestavy které se označím například označením myší

language="VBSCRIPT"

Sub CATMain()

' ******************************* test If product is open *****************************

If CATIA.Documents.Count = 0 Then

MsgBox "There is no CATIA Documents open. Open a Product file and run this script again.", ,msgboxtext

Exit Sub

End If

If InStr(CATIA.ActiveDocument.Name, ".CATProduct") < 1 Then

MsgBox "Active CATIA Document is not a Product. Open a Product file and run this script again.", ,msgboxtext

Exit Sub

End If

' ******************************* variables *******************************************

Set bom = CreateObject("Scripting.Dictionary")

Set ItemSelection = CATIA.ActiveDocument.Selection   

Set cad = CATIA.ActiveDocument

Set sel = cad.selection

Set prod= cad.product.products





Dim tab(4,1999)

Dim tab2(4,1999)

k=0

' ******************************* test If some parts is selected **********************

If sel.count =0 Then

MsgBox "Select parts from tree.", ,msgboxtext

Exit Sub

End If

If sel.count >=1999 Then

MsgBox "Number of selected parts For BOM exceeds 1999. Program error.", ,msgboxtext

Exit Sub

End If

' ******************************* load ************************************************

For i=1 to prod.count

For j=1 to sel.count

If prod.item(i).name=sel.item(j).reference.name then

k=k+1

tab(1,k)=prod.item(i).PartNumber

'tab(2,k)=sel.item(j).reference.name

'tab(3,k)=prod.item(i).DescriptionRef

tab(4,k)=1

End if

next

next

' ******************************* sort ************************************************

If k>1 then

For i=1 to k-1

For j=i+1 to k

If tab(1,i)>tab(1,j)then

tab(1,1999)=tab(1,j)

'tab(2,1999)=tab(2,j)

tab(3,1999)=tab(3,j)

tab(4,1999)=tab(4,j)

tab(1,j)=tab(1,i)

'tab(2,j)=tab(2,i)

tab(3,j)=tab(3,i)

tab(4,j)=tab(4,i)

tab(1,i)=tab(1,1999)

'tab(2,i)=tab(2,1999)

tab(3,i)=tab(3,1999)

tab(4,i)=tab(4,1999)

End if

next

next

' ******************************* count ***********************************************

Dim total, linecount, totalcount

total=1

linecount=1

totalcount=1







For i=1 to k

If tab(1,i)=tab(1,i+1) then

linecount=linecount+1

End if

If tab(1,i)<>tab(1,i+1) then

tab2(1,totalcount)=tab(1,i)

tab2(4,totalcount)=linecount

totalcount=totalcount+1

linecount=1

End if

tab2(4,totalcount)=linecount

next



End if



k=totalcount-1



' ******************************* output to excel *************************************

'For i=1 to k

'msgbox i & " " & tab(1,i) & " " & tab(2,i) & " " & tab(3,i) & " " & tab(4,i)

'next

Dim xlApp

Err.Clear

On Error Resume Next

' Set xlApp = GetObject(,"Excel")

Set xlApp = GetObject(,"EXCEL.Application")

If Err.Number <> 0 Then

Err.Clear

' Set xlApp = CreateObject("Excel")

Set xlApp = CreateObject("EXCEL.Application")

End If

xlApp.Visible = True

xlApp.Workbooks.Add

If Err.Number <> 0 Then

msgbox "Can't open excel.", ,msgboxtext

workbook.Close

xlApp.Quit

End if

row=1

col=1

xlApp.Cells(row, col+1).Value = "CATProduct:"

xlApp.Cells(row, col+1).Font.Bold = true

xlApp.Cells(row+1, col+1).Value = cad.name

row=4

xlApp.Cells(row, col+1).Value = "Part Number"

xlApp.Cells(row, col+2).Value = " "

xlApp.Cells(row, col+3).Value = "Description"

xlApp.Cells(row, col+4).Value = "QNT."

xlApp.Columns.Columns(2).Columnwidth = 30

xlApp.Columns.Columns(3).Columnwidth = 30

xlApp.Columns.Columns(4).Columnwidth = 50

For i=1 to 4

xlApp.Cells(row,col+i).Interior.ColorIndex = 40

xlApp.Cells(row,col+i).Font.Bold = true

xlApp.Cells(row,col+i).HorizontalAlignment = 3

xlApp.Cells(row,col+i).borders.LineStyle = 1

xlApp.Cells(row,col+i).borders.weight = -4138

next

' row=row+1

For i=1 to k

xlApp.Cells(row+i,col+1).Value = tab2(1,i)

'xlApp.Cells(row+i,col+2).Value = tab(2,i)

'xlApp.Cells(row+i,col+3).Value = trim(tab(3,i))

xlApp.Cells(row+i,col+4).Value = tab2(4,i)

For j=1 to 4

xlApp.Cells(row+i,col+j).Interior.ColorIndex = 19

xlApp.Cells(row+i,col+j).Font.Bold = false

xlApp.Cells(row+i,col+j).borders.LineStyle = 1

next

next

xlApp.Cells(row+i,col).Select

' xlApp.Cells(1, 1).HorizontalAlignment = 2

End Sub