' Sample 17.3: 
' 

Sub Main

	Call Pick
	call BOM
	StatusBarText = "The export is complete"
	MsgBox "The export is complete" , vbOkOnly , "Prompt"
End Sub

Sub Pick

	Dim ComponentLayerTypeTop
	Dim ComponentLayerTypeBOT
	ComponentLayerTypeTop = -1
	ComponentLayerTypeBOT  = -1
	
	
	For Each slayer In ActiveDocument.Layers

		Dim sLayerType 
		Dim sLayerNumber 	

		sLayerType = slayer.Type
		sLayerNumber = slayer.Number
		
		If sLayerType = ppcbLayerComponent  Then
			If ComponentLayerTypeTop = -1   Then
				
				ComponentLayerTypeTop = sLayerNumber
				
			ElseIf  ComponentLayerTypeBOT = -1   Then
			
				ComponentLayerTypeBOT  = sLayerNumber
				
			End If		
		End If
	Next slayer
	
	

	Const Columns = Array("Designator",	"Footprint",	"Mid X",	"Mid Y",	"Ref X",	"Ref Y",	"Pad X",	"Pad Y",	"Layer",	"Rotation",	"Comment")',"Pins","SMD", "Glued")
	tempFile = DefaultFilePath & "\temp.txt"
	Open tempFile For Output As #1

	'Output table header
	For i = 0 to UBound(Columns)
		OutCell Columns(i)
	Next
	Print #1
	'Output table rows
	'
		OutCell ""       
		OutCell ""
		OutCell ""
		OutCell ""
		
		OutCell ""
		OutCell ""
		
		OutCell ""
		OutCell ""	
		
		OutCell ""
		OutCell ""
		OutCell ""	
		Print #1
		
	part_Count = ActiveDocument.Components.Count
	ActiveDocument.unit = ppcbUnitMetric
	
	
	now_Count = 0
	For Each part in ActiveDocument.Components
		if part.Pins.Count > 1 then
			OutCell part.Name        
			OutCell part.Decal
			
			Dim centerX  As Single
			Dim centerY  As Single
			Dim cout  As Integer
			centerX = 0.0
			centerY = 0.0
			cout = 0
			
			For Each nextCompPin In part.Pins
				centerX = centerX+nextCompPin.PositionX 
				centerY = centerY+nextCompPin.PositionY 
			Next nextCompPin
			'centerPositionX = Format$(centerX/(part.Pins.Count), "#.00")
			'centerPositionY = Format$(centerY/(part.Pins.Count), "#.00")
			If centerX <> 0 Then
				OutCell Format( centerX/(part.Pins.Count) , "0.000") &"mm"
			Else
				OutCell Format( centerX, "0.000") &"mm"
			End If
			
			If centerY <> 0 Then
				OutCell Format( centerY/(part.Pins.Count), "0.000") &"mm"
			Else
				OutCell Format( centerY, "0.000") &"mm"
			End If
			
			
			
			
			'OutCell Format(part.PositionX, "0.000")
			'OutCell Format(part.PositionY, "0.000")
			

			OutCell Format(part.PositionX, "0.000") &"mm"
			OutCell Format(part.PositionY, "0.000") &"mm"

			Set pin_1 = ActiveDocument.Pins( part.Name & ".1")
			
			If pin_1 Is Nothing Then
				OutCell ""
				OutCell ""		
			Else
				OutCell Format(ActiveDocument.Pins( part.Name  & ".1").PositionX, "0.000") &"mm"
				OutCell Format(ActiveDocument.Pins( part.Name  & ".1").PositionY, "0.000") &"mm"	
			End If
			
			Dim partLayerName As String	
			
			partLayerName =  ActiveDocument.LayerName(part.layer)
			
			If partLayerName = "TopLayer" Or partLayerName = "Top" Then
				partLayerName = "T"	
			ElseIf  partLayerName = "Botlayer" Or partLayerName = "Bot"  Or partLayerName = "Bottom" Then
				partLayerName = "B"	
			ElseIf part.layer = ComponentLayerTypeTop  And ComponentLayerTypeTop<> -1 And ComponentLayerTypeBOT<> -1 Then
				partLayerName = "T"
			ElseIf  part.layer = ComponentLayerTypeBOT And ComponentLayerTypeBOT<> -1 And ComponentLayerTypeTop<> -1 Then		
				partLayerName = "B"		
			Else
			    partLayerName = "T or B??"
			End If
			
			OutCell partLayerName
			
			If partLayerName = "B" Then	
				 Dim Orientation
				 Orientation = 0
				 Orientation = 360 - part.Orientation  ''Convert to counterclockwise
				 Orientation = Orientation - 180       ''Mirror			     			     
				 If Orientation<0 Then
					Orientation = Orientation + 360	   'Turn positive		        
				 End If
				 OutCell Format(Orientation,"0.00") 
			Else
				OutCell Format(part.Orientation,"0.00")
			End If
			
			if AttrVal(part, "Comment")	<> "" then
				OutCell AttrVal(part, "Comment")
			ElseIf	 AttrVal(part, "Value")	<> "" Then
				OutCell AttrVal(part, "Value")
			Else
				OutCell part.PartType
			End If		

			
			'OutCell part.Pins.Count
			'OutCell Format(part.IsSMD, "Yes/No")
			'OutCell Format(part.Glued, "Yes/No")
			

			
			Print #1
		End If
		now_Count = now_Count + 1		
		StatusBarText = "Pick:"& part.Name    &" "& now_Count &"/"&  part_Count		
	Next part

	Close #1
	Call ExportToExcel( ActiveDocument.FullName, "Pick Place for  ") 

End Sub

Sub BOM
	Const Columns = Array("Comment", "Description", "Designator", "Footprint", "LibRef", "Pins", "Quantity")
	Dim part_Count As Integer
	''Dim Parts(1 To 1, 1 To 14) As String '
	
	part_Count = 0 'ActiveDocument.Components.Count
	
	For Each part In ActiveDocument.Components
		if part.Pins.Count > 1 then
			part_Count = part_Count + 1
		end if
		
	Next part	
	ReDim Parts(part_Count, 14) As String '

	tempFile = DefaultFilePath & "\temp.txt"
	Open tempFile For Output As #1

	'Output table header
	For i = 0 to UBound(Columns)
		OutCell Columns(i)
	Next
	Print #1
	'Output table rows
	'
		OutCell ""       
		OutCell ""
		OutCell ""
		
		OutCell ""
		OutCell ""
		OutCell ""
		OutCell ""
		OutCell ""	
		Print #1
		
	ActiveDocument.unit = ppcbUnitMetric
	
	intI = 	1
	now_Count = 0
	
	For Each part In ActiveDocument.Components
		if part.Pins.Count > 1 then
			Dim Comment_s As String

			if AttrVal(part, "Comment")	<> "" then
				Comment_s = AttrVal(part, "Comment")
			ElseIf	 AttrVal(part, "Value")	<> "" Then
				Comment_s = AttrVal(part, "Value")
			Else
				Comment_s = part.PartType
			End If
			
			Parts(intI,1) = part.PartType
			Parts(intI,2) = Comment_s
			Parts(intI,3) = AttrVal(part, "Description")
			Parts(intI,4) = part.Name 
			Parts(intI,5) = part.Decal
			Parts(intI,6) = AttrVal(part, "SuppliersPartNumber")
			Parts(intI,7) = part.Pins.Count
			
			intI  = intI + 1
		end if
		now_Count = now_Count + 1
		StatusBarText = "BOM:"& part.Name    &" "& now_Count &"/"&  part_Count			
	Next part
	
	Dim comp_counter As Integer
	Dim Species As Integer
	Const search_flag As Integer = 8
	
	Dim Component As String
	Dim Component_temp  As String
	Dim label As String 
	
	comp_counter = 0
    Species = 0

    For i = 1 To UBound(Parts, 1)  '标记物料属性形同    
        If Parts(i, search_flag) = "" Then  '是否已经查找过        
            Component = Parts(i, 1) & Parts(i, 2)  & Parts(i, 3)  & Parts(i, 5)   & Parts(i, 6)   & Parts(i, 7)              
            label = Parts(i, 4) '标号   
            
            comp_counter = 1            
            For j = i + 1 To UBound(Parts, 1) 
                Component_temp =  Parts(j, 1) & Parts(j, 2)  & Parts(j, 3)  & Parts(j, 5)   & Parts(j, 6)    & Parts(j, 7)       
                
                If Component = Component_temp Then                
                    comp_counter = comp_counter + 1                    
                    label = label & ", " & Parts(j, 4)      '标号                    
                    Parts(j, search_flag) = "0"            '标记为已经查找过
                    Parts(j, search_flag + 1) = Str(i)     '标记在那一行找到的
					'200个位号每行
					if comp_counter >= 200	then
						Exit For
					End If
                End If                
            Next j
 
            Parts(i, search_flag + 2) = label '用料标号
            Parts(i, search_flag + 3) = Str(comp_counter) '用料数量

            Species = Species + 1
        End If
    Next i


    '填入物料
    Dim NO_ As Integer
    
    'ReDim SpeciesArray(Species, 9)
    ReDim SpeciesArray(Species, 7)
    
    NO_ = 1
    For i = 1 To UBound(Parts, 1) '标记物料属性形同
        If Parts(i, search_flag) = "" Then  '是否已经查找过
        	SpeciesArray(NO_, 1) = Parts(i, 2)                   'Value
        	SpeciesArray(NO_, 2) = Parts(i, 3)                   'Description
        	SpeciesArray(NO_, 3) = Parts(i, search_flag + 2)     'Designator
        	SpeciesArray(NO_, 4) = Parts(i, 5)                   'Footprint
        	SpeciesArray(NO_, 5) = Parts(i, 6)                   'LibRef",
        	SpeciesArray(NO_, 6) = Parts(i, 7)                   'Pins
        	SpeciesArray(NO_, 7) = Parts(i, search_flag + 3)     'Quantity   

            NO_ = NO_ + 1            
        End If
    Next i
    
	For i = 1 To UBound(SpeciesArray, 1) 
		For j =1 To 7
			OutCell SpeciesArray(i,j) 		
		Next j
		Print #1	
	Next i

	Close #1
	Call ExportToExcel( ActiveDocument.FullName  ,"BOM for ")


End Sub



Sub ExportToExcel (txt As String, FileType As String)
	FillClipboard
	Dim xl As Object	
	Dim Path As String
	Dim FileName As String
	
	Path = ParsePath(txt)
	FileName = GetFileNameNoExt(txt)

	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.Range("A:K").NumberFormat = "@"
	xl.Range("A1:K1").NumberFormat = "@"
	xl.ActiveSheet.Paste
	xl.Range("A1:K1").Font.Bold = True
	xl.Range("A1:K1").NumberFormat = "@"
	'xl.ActiveSheet.UsedRange.Columns.AutoFit
	If StrComp("BOM for ",FileType) = 0 Then
		xl.ActiveSheet.Range("A1").AddComment("This is Comment or Value or PartType")
		xl.ActiveSheet.Range("C1").AddComment("This is Name")
		xl.ActiveSheet.Range("D1").AddComment("This is Decal")
		xl.ActiveSheet.Range("E1").AddComment("This is SuppliersPartNumber")
	End If
	
	
	xl.Range("A1").Select
	xl.Application.DisplayAlerts = False
    'MsgBox xl.Version    
    
	xl.activeworkbook.SaveAs(Path & FileType &FileName &".xls" ,56)
	
	''xl.workbooks.close
	''xl.Quit
    
    
	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
	' 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
End Sub


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


'-----------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------
'此函数从字符串中分离出路径
Function ParsePath(sPathIn As String) As String
    Dim I As Integer
    For I = Len(sPathIn) To 1 Step -1
    If InStr(":\", Mid$(sPathIn, I, 1)) Then Exit For
    Next
   
    ParsePath = Left$(sPathIn, I)
End Function
'此函数从字符串中分离出文件名
Function ParseFileName(sFileIn As String) As String
    Dim I As Integer
    For I = Len(sFileIn) To 1 Step -1
    If InStr("\", Mid$(sFileIn, I, 1)) Then Exit For
    Next
    ParseFileName = Mid$(sFileIn, I + 1, Len(sFileIn) - I)
    End Function
'此函数从字符串中分离出文件扩展名
Function GetFileExt(sFileName As String) As String
    Dim P As Integer
    For P = Len(sFileName) To 1 Step -1
    If InStr(".", Mid$(sFileName, P, 1)) Then Exit For
    Next
    GetFileExt = Right$(sFileName, Len(sFileName) - P)
End Function
'===========获取文件名但不包括扩展名  aaa
Public Function GetFileNameNoExt(FilePathFileName As String) As String  '获取文件名但不包括扩展名  aaa
    On Error Resume Next
    Dim i As Integer, J As Integer, k As Integer
    i = Len(FilePathFileName)
    J = InStrRev(FilePathFileName, "\")
    k = InStrRev(FilePathFileName, ".")
     If k = 0 Then
        GetFileNameNoExt = Mid(FilePathFileName, J + 1, i - J)
    Else
       GetFileNameNoExt = Mid(FilePathFileName, J + 1, k - J - 1)
    End If
 
End Function