PADS Logic BOM Output

Dim fn As String Sub Main fn = ActiveDocument If fn = "" Then fn = "Untitled" End If tempFile = DefaultFilePath & "\temp.txt" Open tempFile For Output As #1 item = 0 StatusBarText = "Generating report..." Print #1, "ITEM";vbTab;"Part Type"; vbTab;"P/N_1"; vbTab;"Manufacturer_1_P/N"; vbTab;"Description"; vbTab;"Manufacturer_1"; vbTab; "Value"; vbTab; "QTY"; vbTab; "REF-DES" For Each pkg in ActiveDocument.PartTypes 'Print #1, pkg.Name; vbTab; note qty = 0 value = "" description = "" manufacturer = "" pn = "" manufacturerpn = "" symbol = "" item = item + 1 'Print #1, item; vbTab; For Each part In pkg.Components value = AttrValue(part, "Value" ) description = AttrValue(part, "Description" ) manufacturer = AttrValue(part, "Manufacturer_1" ) pn = AttrValue(part, "P/N_1" ) value = AttrValue(part, "Value" ) manufacturerpn = AttrValue(part, "Manufacturer_1_P/N" ) sysid = AttrValue(part, "SYSID" ) qty = qty+ 1 symbol = symbol + part.Name + ", " Next symbol_len = Len(symbol) symbol = Mid (symbol, 1 , symbol_len - 2 ) Print #1, item; vbTab; part.PartType ; vbTab; pn ; vbTab;manufacturerpn; vbTab;description; vbTab;manufacturer; vbTab;value; vbTab; qty; vbTab; symbol; Print #1 Next pkg StatusBarText = "" Close #1 ExportToExcel End Sub Sub ExportToExcel FillClipboard Dim xl As Object On Error Resume Next Set xl = GetObject(, "Excel.Application" ) On Error GoTo ExcelError ' Enable error trapping. If xl Is Nothing Then Set xl = CreateObject( "Excel.Application" ) End If xl.Visible = True xl.Workbooks.Add xl.ActiveSheet.Paste xl.Range( "A1:I1" ).Font.Bold = True xl.Range( "A1:I1" ).NumberFormat = "@" xl.Range( "A1:I1" ).AutoFilter xl.ActiveSheet.UsedRange.Columns.AutoFit 'Output Report Header xl.Rows( 1 ).Insert xl.Rows( 1 ).Cells( 1 ) = Space( 1 ) & "Part Report " & " WWZL-BOM " & " on " & Now xl.Rows( 2 ).Insert xl.Rows( 1 ).Font.bold = True 'Output Design Totals lastRow = xl.ActiveSheet.UsedRange.Rows.Count + 1 xl.Rows(lastRow + 1 ).Font.bold = True xl.Rows(lastRow + 1 ).Cells( 1 ) = Space( 1 ) & "Design Part count: " & ActiveDocument.Components.Count xl.Range( "A1" ). Select On Error GoTo 0 ' Disable error trapping. Exit Sub ExcelError: MsgBox Err.Description, vbExclamation, "Error Running Excel" On Error GoTo 0 ' Disable error trapping. Exit Sub End Sub Sub FillClipboard StatusBarText = "Export Data To Clipboard..." ' Load whole file to string variable tempFile = DefaultFilePath & "\temp.txt" Open tempFile For Input As #1 L = LOF( 1 ) AllData$ = Input$(L, 1 ) Close #1 'Copy whole data to clipboard Clipboard AllData$ Kill tempFile StatusBarText = "" End Sub Function AttrValue (comp As Object , atrName As String ) As String If comp.Attributes(atrName) Is Nothing Then AttrValue = "" Else AttrValue = comp.Attributes(atrName).Value End If End Function