自己写的一段小程序，用于将PADS Layout的数据导出制成BOM，因为以前都是用C++，从没写过VB，所以七拼八凑弄出来的这段东西虽然用着没问题，但是速度还不是尽如人意，实在没时间弄它了，希望有高手看到帮忙修正一下，最好能把第一段分类元件处的代码改成队列形式的，查到一个元件后就将这个元件出列，不断减小队列长度，应该可以大大提高程序运行速度。我自己也写了一段，但不大了解VBS的用法，所以老是报错。

说下用法：先打开PADS Layout，打开要制作BOM的PCB文件，再选TOOLS -> BASIC SCRIPTS -> BASIC SCRIPT EDITOR，将下面的代码复制进去替换掉原来的那两行，然后保存，运行，不一会就会弹出一个EXCEL窗口，里面就是BOM了，PART NO.自己填一下哈

此程序慢是慢了点，但总比手工计算要快很多，软件制成的BOM经过生产检验是没有问题的，请大家放心使用

'This script has been generated by PowerPCB's VB Script Wizard on 2007-07-06 16:40:06
'It will create reports in Microsoft Excel Format.
'You can use the following code as a skeleton for your own VB scripts

'Array of column names. You can modify it to rename columns
Const Columns = Array("PCB Decal", "Part Type" , "Value" , "Amount" , "Name")
'Array of column alignment: 0 - Align Left, 1 - Align Right, 2 - Align Center.
Const Align   = Array(     0,       0,           0,           2,           0)
Dim fname As String

'1.0 Origin
'1.1 Add the PCB part number line
'1.2 Add the Part Value filter to delete the unused component
'1.3 Add the support for the jumpers
'1.4 Range the part names whitch in one single line
'1.5 Speed UP!

Sub Main
starttime=Now
fname = ActiveDocument
If fname = "" Then
   fname = "Untitled"
End If
tempFile = DefaultFilePath & "\temp.txt"
Open tempFile For Output As #1

StatusBarText = "Generating report..."
'Output table header
For i = 0 To UBound(Columns)
   OutCell Columns(i)
Next
Print #1
Dim x()
Dim t1()
ReDim x(10000)
ReDim t1(10000)

Dim tstr as String
total=0
totaltypes=0

'Copy every part's data into an array.
For Each part In ActiveDocument.Components
   tstr="AttrVal"(part, "Value")
'Ignore the patr whitch value is ***,NC,X,XXX,open
   If tstr= "open" Or tstr="Open" Or tstr="OPEN" Or tstr= "open." Or tstr="Open." Or tstr="OPEN." _
     Or tstr = "**" Or tstr="***" Or tstr = "NC" Or tstr="nc" Or tstr="NC."Or tstr="nc."Or tstr="X" _
     Or tstr="XXX" Or tstr="x" Or tstr="xxx"Or tstr="Nc"Or tstr="Nc."Then
    GoTo passit
   End If
   x(total)=part
  
   tstr="x"(total).PartType+","+x(total).Decal+","+tstr
   For i="0" To totaltypes
    If t1(i)=tstr Then   'Found all the different types of the component
     GoTo found_the_part
    End If
   Next i
   t1(totaltypes)=tstr
   totaltypes="totaltypes"+1
   found_the_part:
   total="total"+1
passit:
Next part
ReDim Preserve x(total)
ReDim Preserve t1(totaltypes)
total=total-1
totaltypes=totaltypes-1

'Output the PCB's information
OutCell fname
OutCell "PCB"
OutCell "Attribute of the PCB"
OutCell "1"
OutCell "-"
Print #1

For i_types=0 To totaltypes 'Range the component types
   For j_types=i_types To totaltypes
    If t1(i_types)<t1(j_types) Then
     tstr="t1"(i_types)
     t1(i_types)=t1(j_types)
     t1(j_types)=tstr
    End If
   Next j_types
Next i_types

Dim amount as integer, i_names as integer, j_names as integer
Dim str_name As String, str_decal As String, str_parttype As String, str_value As String
Dim tmpstr_name()

For i = 0 To totaltypes   'Pick the names in same type（此处需改善）
   ReDim tmpstr_name(300)
   amount="0"
   For j = 0 To total
    tstr="AttrVal"(x(j), "Value")
    tstr="x"(j).PartType+","+x(j).Decal+","+tstr
    If t1(i) = tstr Then
     tmpstr_name(amount)=x(j).Name
     amount="amount"+1
     str_decal=x(j).Decal
     str_parttype=x(j).PartType
     str_value=AttrVal(x(j), "Value")
    End If
   Next j
   ReDim preserve tmpstr_name(amount)
  
   For i_names = 0 To amount-1   'Range the types
    For j_names = i_names To amount-1
     If compare(tmpstr_name(i_names),tmpstr_name(j_names))=2 Then
      tstr="tmpstr"_name(i_names)
      tmpstr_name(i_names)=tmpstr_name(j_names)
      tmpstr_name(j_names)=tstr
     End If
    Next j_names
   Next i_names
   str_name=tmpstr_name(0)
   If amount > 1 Then
    For i_names = 1 To amount-1
     str_name = str_name + "," + tmpstr_name(i_names)
    Next i_names
   End If
  
   OutCell str_decal
   OutCell str_parttype
   OutCell str_value
   OutCell CStr(amount)
   OutCell str_name
   Print #1
Next i

'Fill the jumpers' information below
Dim jx As Double
Dim ji As Integer

Dim JumperLength()
ReDim JumperLength(3000)
Dim JumperName()
ReDim JumperName(3000)

Dim tj 'total jumper

tj = 0

Dim jleng As Double
Dim jstr As String

For Each jmp In ActiveDocument.Jumpers 'Pick up the length and name of the jumpers to two array
   jx = jmp.Length
   ji = (((jx+0.25)*2)-0.5) 'Convert the length to the *.5 format, just like "2.24mm -> 2.0mm" or "2.25mm -> 2.5mm"
   jx = ji/2
   JumperLength(tj)=jx
   JumperName(tj)=jmp.Name
   tj = tj + 1
Next jmp

If tj = 0 Then
   GoTo nojumpers
End If

ReDim Preserve JumperLength(tj-1) 'Redefine the length of the array
ReDim Preserve JumperName(tj-1)

For i = 0 To tj-1 'Range the array by the length
   For j = i To tj-1
    If JumperLength(i) < JumperLength(j) Then
     jleng="JumperLength"(i)
     JumperLength(i)=JumperLength(j)
     JumperLength(j)=jleng
    
     jstr="JumperName"(i)
     JumperName(i)=JumperName(j)
     JumperName(j)=jstr
    End If
   Next j
Next i

Dim jstr_array()
ReDim jstr_array(300)

For i = 0 To tj-1 'Fill the jumpers' informationes to the table
   ReDim jstr_array(300)
   jstr_array(0) = JumperName(i)
   amount = 1
   For j = i+1 To tj-1
    If JumperLength(i) = JumperLength(j) Then
     jstr_array(amount) = JumperName(j)
     amount = amount + 1
    Else
     GoTo nextjumper
    End If
   Next j
   nextjumper:
   OutCell "1.635N.0004-0"
   OutCell "铁线"
   OutCell "L="+CStr(JumperLength(i))+"mm"
   OutCell CStr(amount/10000)
   
   ReDim Preserve jstr_array(amount-1)
   For i_names = 0 To amount-1
    For j_names = i_names To amount-1
     If compare(jstr_array(i_names),jstr_array(j_names))=2 Then
      jstr="jstr"_array(i_names)
      jstr_array(i_names)=jstr_array(j_names)
      jstr_array(j_names)=jstr
     End If
    Next j_names
   Next i_names
   jstr="jstr"_array(0)
   If amount > 1 Then
    For i_names = 1 To amount-1
     jstr = jstr + "," + jstr_array(i_names)
    Next i_names
   End If
  
   OutCell jstr
   i = j-1
   Print #1
Next i

nojumpers:

FillAuthorText


StatusBarText = ""
Close #1
ExportToExcel
endtime=Now-starttime

p_time="Processing accomplished, used time is "+Format(endtime,"hh:mm:ss")
MsgBox p_time
End Sub

Function AttrVal (obj As Object, nm As String)
AttrVal = IIf(obj.Attributes(nm) Is Nothing, "", obj.Attributes(nm))
End Function

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:E1").Font.Bold = True
xl.Range("A1:E1").NumberFormat = "@"
xl.Range("A1:E1").AutoFilter
For i = 0 To UBound(Align)
   xl.Columns(i + 1).HorizontalAlignment = Choose(Align(i)+1, -4131, -4152, -4108)
Next
xl.ActiveSheet.UsedRange.Columns.AutoFit
'Output Report Header
xl.Rows(1).Insert
xl.Rows(1).Cells(1) = Space(1) & "PCB文件名： " & fname & " BOM生成时间： " & Now
xl.Rows(2).Insert
xl.Rows(1).Font.bold = True
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 OutCell (txt As String)
Print #1, txt; vbTab;
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
Sub FillAuthorText
Print #1
OutCell "BOM Counter, Ver: 1.5"
Print #1
OutCell "By: XuQiuming, 2008-11-20"

End Sub

Function compare(a As String , b As String) As Integer   ' 1-> a<b 2-> a>b 0-> a="b"
Dim a_str()
Dim b_str()
ReDim a_str(10)
ReDim b_str(10)

Dim segtype
segtype = 0
Dim sega
Dim segb
sega=0
segb=0

Dim segstr
For i="0" To Len(a)-1
   segstr="Mid"(a,i+1,1)
   If Asc(segstr)>47 And Asc(segstr)<59 Then 'the char is a number
    Select Case segtype
    Case 1
     a_str(sega)=a_str(sega)+segstr
    Case 0
     a_str(0)=segstr
     segtype="1"
    Case 2
     sega="sega"+1
     a_str(sega)=segstr
     segtype="1"
    End Select
   Else
    Select Case segtype
    Case 2
     a_str(sega)=a_str(sega)+segstr
    Case 0
     a_str(0)=segstr
     segtype="2"
    Case 1
     sega="sega"+1
     a_str(sega)=segstr
     segtype="2"
    End Select
   End If
Next i

segtype=0

For i="0" To Len(b)-1
   segstr="Mid"(b,i+1,1)
   If Asc(segstr)>47 And Asc(segstr)<59 Then 'the char is a number
    Select Case segtype
    Case 1
     b_str(segb)=b_str(segb)+segstr
    Case 0
     b_str(0)=segstr
     segtype="1"
    Case 2
     segb="segb"+1
     b_str(segb)=segstr
     segtype="1"
    End Select
   Else
    Select Case segtype
    Case 2
     b_str(segb)=b_str(segb)+segstr
    Case 0
     b_str(0)=segstr
     segtype="2"
    Case 1
     segb="segb"+1
     b_str(segb)=segstr
     segtype="2"
    End Select
   End If
Next i

If sega<segb Then
   t="sega"
Else
   t="segb"
End If

Dim x1 As Integer, x2 As Integer
dim cresult as integer   ' 1-> a<b 2-> a>b 0-> a="b"
cresult=0
For i="0" To 9
   If (Asc(Mid(a_str(i),1,1)))>47 And (Asc(Mid(a_str(i),1,1)))<59 And _
    (Asc(Mid(b_str(i),1,1)))>47 And (Asc(Mid(b_str(i),1,1)))<59 Then
    x1=CInt(a_str(i))
    x2=CInt(b_str(i))
    If x1<x2 Then
     cresult="1"
     goto cend
    end if
    if x1>x2 then
     cresult="2"
     goto cend
    end if
   else
    If a_str(i)<b_str(i) Then
     cresult="1"
     goto cend
    end if
    if a_str(i)<b_str(i) then
     cresult="2"
     goto cend
    end if
   end if
next i

If sega<segb Then
   cresult="1"
Else
   cresult="2"
End If

cend:
compare=cresult

End Function

*博客内容为网友个人发布，仅代表博主个人观点，如有侵权请联系工作人员删除。