IPC-D-356A Netlist Extractor

IPC-D-356A_Netlist_Extractor-4.7.1.bas

Const Version = "4.7.1"        ' Current version of program

'**************** Added 07/05/01 by c.friese

Const MakeDecalArrayDebugFile = False 'True 

'if true, the script writes the Decalarray
'to "Document.path\ActiveDocumentBaseName" + "_decal.rep" 

'*******************************************

'=========================================================================
'
' PowerPCB VB Script: IPC-D-356A_Netlist_Extractor.4_7_1.bas
'
' Generates an IPC-D-356A netlist from a PowerPCB database.
'
'=========================================================================
'
' Copyright (C) John Brown
' 
' This program Is free software; you can redistribute it And/Or
' modify it under the terms of the GNU General Public License
' As published by the Free Software Foundation; either Version 2
' of the License, Or (at your Option) Any later Version.
' 
' This program Is distributed In the hope that it will be useful,
' but WITHOUT Any WARRANTY; without even the implied warranty of
' MERCHANTABILITY Or FITNESS For A PARTICULAR PURPOSE.  See the
' GNU General Public License For more details.
' 
' You should have received a copy of the GNU General Public License
' along With this program; 
' If Not, Write To: 
' the Free Software Foundation, Inc.
' 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
' www.fsf.org
' www.fsf.org/copyleft/gpl.html
'
' the GNU General Public License is License_GPL.txt
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'##########################################################################################
' Help Text
'##########################################################################################
'# ----------------------------------------------------------------------------------------
'#                            USING THE EXTRACTED NETLIST
'# ----------------------------------------------------------------------------------------
'# If you have CAM350 you can use the extracted netlist To verify your gerber data.
'# 
'# !!! You must have a current build of CAM350 - CAM350 v6.0 build 154 Or higher.
'# !!! You have To load drill data.
'# !!! All of your gerber files And the drill data must Line up !!!
'# 
'# Here's what you do:
'#         > load your gerber data In CAM350
'#            - you must include drill data ( so the CAM software can tell how one layer
'# 	     connects To the other
'#            - All of the layers must Line up ( see Notes about layer alignment below )
'# 	     This includes the drill data
'#         > Identify the Type For Each layer In Tables > Layers
'#         > adjust the origin To be In the same place that it Is In the PowerPCB database.
'# 	    The ipc netlist gives the positions of things In the PowerPCB database.
'#             If you don't do this, you will get zillions of errors because nothing will 
'#             be In the Right place.
'# 		- Edit > Change > Origin > Space Origin
'# 		- Then Select the New origin location
'# 	    I find it helpfull To Put the origin On a drill hole. Then, In CAM350
'# 	    you use "object snap" (the "Z" button In the bottom Right corner) To Select 
'# 	    the hole that needs To be at the origin (turn the "S" (grid snap) And the 
'# 	    "V" (grid visibility) off). That way the origin change Is very prescise.
'#         > Extract a netlist - Utilities > Netlist Extract
'#         > Import the ipc-356 netlist - File > Import > Netlist, IPC-356A
'#             This will import the netlist And perform a comparison.
'# 
'# If All goes well you will Get a message saying "import netlist complete, no errors found"
'# If there are discrepancies you will Get a list of the errors.
'# 
'# !!!Warning !!! Builds of CAM350 v6.0 previous To build 154 Do Not corretcly 
'# support Long Net names (Net names longer than 14 chars). You can check your build 
'# number by going To Info > Status.
'# 
'# I'm sure the same test can be run with other cam software; but I cannot provide 
'# instructions For doing As I have only CAM350.
'# 
'# ----------------------------------------------------------------------------------------
'#                       NOTES ABOUT REGENERATION OF APERTURES
'# ----------------------------------------------------------------------------------------
'# If you don't do anything and just generate gerber files - you will get gerber files 
'# which have "drawn" surface mount pads. However, If you regenerate the apertures before 
'# you Write the gerber files the surface mount pads will come out As "flashed" pads 
'# instead.
'# 
'# In my first rounds of testing the ipc-356 script I did Not have Any problems because of 
'# this. But, For some reason, I've started running into trouble with "drawn" pads. For 
'# some reason, when you try To compare a Set of gerber files that have "drawn" surface 
'# mount pads To an ipc netlist you will Get lots of errors. I don't know why it has not 
'# shown up before; but I think it has something To Do With the latest builds of CAM350 
'# (but I'm not sure).
'# 
'# My guess Is that CAM350 likes To see a pad at Each End of a track. To CAM350 a pad Is a
'# '# flash. When the pads are drawn they just look Like more routing so it doesn't find the 
'# End of the Net.
'# 
'# At Any rate, what I've found is that if I do regenerate the apertures before writing the 
'# gerber files, the errors All go away. Relying On "augment on the fly" will produce 
'# "drawn" pads. Regenerating Is the only way To make sure you Get "flashed" pads.
'# 
'# 
'# regenerating apertures:
'#         > go To File > CAM
'#         > edit Any gerber Document
'#         > Choose "device setup"
'# 	> Select All existing apertures And press delete
'#         > press the "regenerate" button
'# It will take some Time To run, but when it Is done, the master aperture table (For this 
'# board) will contain All apertures needed To photoplot every shape In the entire board. 
'# Plus the photoplot will contain "flashed" surface mount pads instead of "drawn" pads.
'# 
'# ----------------------------------------------------------------------------------------
'#                           NOTES ABOUT LAYER ALIGNMENT
'# ----------------------------------------------------------------------------------------
'# '# If you just Let PowerPCB Do what it wants To Do, it's default way of positioning data in 
'# a gerber file Is To use "centered" For justifiying plots. That means that every plot 
'# will be individually centered On the photoplotter bed based On its size And shape. Since
'# every layer will likely have a slightly different size And shape, every plot will be In 
'# a slightly different position And non of the layers will Line up when you load the gerber 
'# data into a viewer.
'# 
'# Of course you can Put some targets On Each layer at the extremes To make sure everthing 
'# lines up. But that does Nothing For the drill data.
'# 
'# You could also align the layers Each Time you load the gerber data. But you have To Do 
'# this every Time you load the gerber files. Plus, alinging In CAM350 depends On selecting
'# a flash On Each layer For the alignment - silk screens have no flahses, so how Do you 
'# align it accurately?
'# 
'# I personally prefer that everthing just Line up when I load the gerber data With no
'# extra effort. So I always use "offset" For the justification. I find that an offset of
'# 10.000in For X And Y works For almost every board so I Put that offset On All gerber
'# files And All drill data. That covers All electrical layers And All documentation layers.
'# You may occaisionally find larger boards And have To change it.
'# 
'# If you use offsets, Then you will only have To Set that offset once. After that, All
'# layers of the gerber data will Line up perfectly With no extra effort On your part.
'##########################################################################################

'=========================================================================
' Version 2
' 11/08/99
' Written by John Brown of Cape CAD Design
' Email: sales@capecad.com
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Version 3
' 2/14/01
' Silicon Hills Design
' Gary Bankston
' gary@siliconhills.com
'-------------------------------------------------------------------------
' 2/14/01 Gary Bankston
' Corrected Access problem for pins
' Access for top side surface mount pins 
' is "01" (top side) 
' not "00" (all sides)
'
'---
' 2/15/01 Gary Bankston
' Corrected Y location caluculation of vias
' typo in calculation for y location of vias was using aPin instead of aVia
' formating or Y position was flawed
'
'---
' 2/14/01 Gary Bankston
' Added numerous comments to make code more readable
'
'---
' 2/15/01 Gary Bankston
' Corrected Calculation of Y position of pins and vias
' X calculation used Val() while Y calculation did not use Val()
'   If Val(aPin.PositionX) > 0 Then
'   If aPin.PositionY > 0 Then
'   If Val(aVia.PositionX) > 0 Then
'   If aVia.PositionY > 0 Then
' Changed logic of calculation of X and Y position of pins and vias
'   from If Val( ... ) > 0 Then
'   to   If VAl( ... ) >= 0 Then
' If Val(aPin.PositionX) >= 0 Then
' If Val(aPin.PositionY) >= 0 Then
' If Val(aVia.PositionX) >= 0 Then
' If Val(aVia.PositionY) >= 0 Then
'
'---
' 2/15/01 Gary Bankston
' Added function FormatPosition()
' for calculation / formating of position
'
'---
' 2/16/01 Gary Bankston
' Added support for long netnames.
' netnames longer than 14 chars require the use of aliases
' which require an NNAME parameter record.
' Added functions getNetname(), createAliases()
'
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Version 4
' 4/09/01
' Written by John Brown of Cape CAD Design
' Email: sales@capecad.com
' Added support for blind and buried vias.
'------------------------------------------
' v4.2
' 4/28/01 Gary Bankston
' changed UnitF for metric unts
' since Pin.DrillSize, Pin.PositionX, Pin.PositionY give their return 
' value in current database units:
' UnitF for metric should be 1000 (instead of 393.7)
' Current database units will control units of the netlist.
'---
' 4/28/01 Gary Bankston
' added an opening dialog and closing dialog.
' The opening dialog allows the user to select the netlist filename
' and set the units.
'   units default to current database units
'   filename defaults to current_database_pathname.ipc
' Changed each DrillSize, PositionX, PositionY reference to use the 
'   units set by the dialog
' The closing Dialog: displays the filename, units used,
' allows user to view the netlist.
'---
' 4/28/01 Gary Bankston
' Changed via section to use LayerType instead of LayerName to determine
' whether each via is thru, blind or buried. (Since it can be changed,
' the bottom layer name might not always be "Bottom" )
'---
' 4/28/01 Gary Bankston
' modified the via code to simplify it and reduce the amount of 
' repeated code
'---
' 5/01/01 John Brown
' changed all references to read ipc-d-356a
'------------------------------------------
' v4.4
' 5/08/01 Gary Bankston
' added code to deal with non-period decimal seperators.
'------------------------------------------
' v4.5
' 5/29/01 Gary Bankston
' added code ( formatDrill() ) to format drill hole size
'------------------------------------------
' v4.7
' 07/04/01 Christian Friese
' Added Decals Collection and read the data from ascii out, to 
' correct the SMD Pin problem (PCI Slot ect.)
' increment version to 4.6
'------------------------------------------
' v4.7.1
' 8/15/01 Gary Bankston
' added simple help system which gives a discussion of several important topics
'=========================================================================

'**************** Added 07/04/01 by c.friese
Dim ElecMaxLayer%

'*******************************************

Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Const MF_BYPOSITION = &h400

' 2/15/01 Gary Bankston, Silicon Hills Design 
' formats positon as six digits, will always have a leading "+" or "-" 
' 5/08/01 a "." (period) is not always the decimal seperator. Europe uses a "," (comma)
'        Added a quick fix to detect the comma. This is a bit of a kludge though. It
'        will only work for a comma. To be a real fix, need some way to find out what 
'        the system setting for the decimal seperator is and then subsitute that with a period.
'        ACTUALLY - shouldn't VB's val() function detect the system's decimal seperator and just
'                   handle this appropriately?
Function FormatPosition( pos )
	If InStr( pos, "," ) <> 0 Then
		pos = Replace( pos, ",", "." )
	End If
	pos = Val( pos )
	If pos >= 0 Then
		fp = Format$( pos * UnitF, "+000000" )
	Else
		fp = Format$( pos * UnitF, "000000" )
	End If

	FormatPosition = fp
End Function

' 5/29/01 Gary Bankston, Silicon Hills Design 
' drill hole size needs to be formated too; but format only needs 4 places
Function FormatDrill( pos )
	If InStr( pos, "," ) <> 0 Then
		pos = Replace( pos, ",", "." )
	End If
	pos = Val( pos )
	fp = Format$( pos * UnitF, "0000" )

	FormatDrill = fp
End Function

' 2/16/01 Gary Bankston, Silicon Hills Design 
' If a netname is longer than 14 chars, look up its alias
' othewise just return the netname unchanged
Function getNetname( netname )
	If Len( netname ) > 14 Then
		' see if this net already has an alias
		For n = 1 To netAliasCnt
			If netname = netAliases(n) Then
				getNetname = "NNAME" + Format$( n )
				Exit Function
			End If
		Next
	Else
		getNetname = netname
		Exit Function
	End If
	getNetname = "no_alias_found"
End Function

' 2/16/01 Gary Bankston, Silicon Hills Design 
' Scans thru all nets looking for net with names longer than 14 chars and
' creates alias for any long net names.
Sub createNetAliases
	Application.StatusBarText = "Creating net name alias for long net names ..."
	Application.ProgressBar = 0
	Dim aliasname As String*5
	n = 0
	netAliasCnt = 0
	netCnt = ActiveDocument.Nets.Count
	For Each aNet In ActiveDocument.Nets
	    n = n + 1
	    Application.ProgressBar = n * 100 / netCnt
		netname = aNet.Name
		If Len( netname ) > 14 Then
			If netAliasCnt = 0 Then
				Print #1, "C  "
				Print #1, "C  netname aliases"
			End If
			netAliasCnt = netAliasCnt + 1
			ReDim Preserve netAliases( netAliasCnt + 1 )
			aliasname = Format$( netAliasCnt )
			netAliases( netAliasCnt ) = netname
			Print #1, "P  NNAME" + aliasname + " " + netname
		End If
	Next

	If netAliasCnt > 0 Then
		Print #1, "C  end alias section"
		Print #1, "C  "
	End If
	Application.ProgressBar = -1
End Sub

' Gary Bankston, Silicon Hills Design 
' 7/9/01
' Crude Help file
Sub HelpFile
	helpf = Document.path & "\helptmp.txt"
	macrof = MacroDir & "\" & MacroName & ".bas"
	Open helpf For Output As #16
	Open macrof For Input As #15
		While Not EOF(15)
			Line Input #15, inline 
			If Left(inline, 3) = "'# " Then 
				Print #16, Replace( inline, "'# ", "" )
			End If
		Wend
	Close #15
	Close #16
	Shell "Notepad " & helpf, 1
	Kill helpf
End Sub

' Gary Bankston, Silicon Hills Design 
' 4/28/01
' Opening Dialog: displays version, license,
' allows the selection of units and netlist file name.
Function StartDialog
	Begin Dialog UserDialog 590,371,"Extract IPC-D-356A Netlist",.OnStart ' %GRID:10,7,1,1
		GroupBox 20,7,550,35,"Version",.GroupBoxVersion
		Text 40,21,170,14,"IPC-D-356A Netlist Extractor",.Text3
		Text 220,21,90,14,"v?.?",.VersionText

		GroupBox 20,49,550,133,"License",.GroupBoxLicense
		Text 40,63,510,14,"This program is distributed under the GNU General Public License.",.Text7
		Text 40,84,500,14,"This program is distributed in the hope that it will be useful,",.Text4
		Text 40,98,490,14,"but WITHOUT ANY WARRANTY; without even the implied warranty of",.Text5
		Text 40,112,510,14,"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.",.Text6
		Text 40,133,510,14,"See the GNU General Public License for more details.",.Text10
		Text 70,161,410,14,"The GNU General Public License is License_GPL.txt",.Text8
		Text 70,147,410,14,"www.fsf.org/copyleft/gpl.html",.Text9

		GroupBox 180,189,390,70,"Compliments of",.GroupBoxComp
		Text 200,210,130,14,"Cape Cad Design",.Text1
		Text 400,210,130,14,"Silicon Hills Design",.Text2
		Text 310,231,130,14,"Christian Friese",.Text11

		GroupBox 20,189,130,70,"Units",.GroupBoxUnits
		OptionGroup .Units
			OptionButton 40,210,90,14,"English",.UnitsEnglish
			OptionButton 40,231,90,14,"Metric",.UnitsMetric
			
		GroupBox 20,266,550,56,"Netlist Filename",.GroupBoxFilename
		TextBox 40,287,410,21,.FilenameEntry
		PushButton 470,287,80,21,"Browse",.BrowseFilename

		CancelButton 260,336,90,21
		OKButton 50,336,90,21
		PushButton 470,336,90,21,"Help",.HelpButton
	End Dialog
	Dim dlg As UserDialog
	If Dialog( dlg ) = 0 Then         ' Cancel
		StartDialog = 0
	Else
		StartDialog = 1               ' Ok
	End If
End Function

' 4/28/01 Gary Bankston, Silicon Hills Design 
' Opening dialog handler
Function OnStart(DlgItem$, Action%, SuppValue&) As Boolean
	Static SuppressFilenameEntry ' used when DlgText "FilenameEntry" is called to suppress circular
	' actions for the FilenameEntry TextBox. Don't know why, but use of DlgText "FilenameEntry" 
	' generates an Action for FilenameEntry. This makes it impossilbe to distinguish between 
	' the user typing in the FilenameEntry TextBox and DlgText "FilenameEntry" calls.
	' That causes circular references mess things up
	' grrrrrrr
	Select Case Action%
	Case 1 ' Dialog box initialization
		' Version
		DlgText "VersionText", "v" & Version
		' units
		If Document.unit = ppcbUnitMetric Then
			DlgValue "Units", 1
		Else                           ' ppcbUnitInch or ppcbUnitMils
			DlgValue "Units", 0
		End If
		' filename
		DlgText "FilenameEntry", Filename
		SuppresFilenameEntry = 1
	Case 2 ' Value changing or button pressed
		Select Case DlgItem
		Case "BrowseFilename"
			newfilename = GetFilePath( Filename, "*", , "Write IPC-D-356A Netlist", 3 )
			If  newfilename <> "" Then
				DlgText "FilenameEntry", newfilename
				SuppressFilenameEntry = 1
			End If
			OnStart = True
		Case "OK"
			Filename = DlgText( "FilenameEntry" )
			If DlgValue( "Units" ) = 1 Then   ' metric
				Units = ppcbUnitMetric
			Else                              ' english
				Units = ppcbUnitInch
			End If
'		Case "Cancel"
		Case "HelpButton"
			HelpFile
			OnStart = True
		End Select
	Case 3 ' text changed
		If DlgItem = "FilenameEntry" Then
			If SuppressFilenameEntry = 1 Then
				SuppressFilenameEntry = 0
				Exit Function
			End If
			newfilename = DlgText( "FilenameEntry" )
			If newfilename = "" Then
				MsgBox( "Empty file name not allowed", vbCritical )
				DlgText "FilenameEntry", Filename
			Else
				If Dir( newfilename ) <> "" Then
					If MsgBox( newfilename & " Exists. Do you want to overwrite?", vbYesNo Or vbExclamation Or vbDefaultButton2 ) = vbNo Then
						DlgText "FilenameEntry", Filename
					End If
				End If
			End If
		End If
	End Select
End Function

' 4/28/01 Gary Bankston, Silicon Hills Design 
' Closing Dialog: displays the filename, units used,
' allows user to view the netlist
Function EndDialog
	If Units = ppcbUnitMetric Then
		unitstr = "Metric"
	Else
		unitstr = "English"
	End If
	Begin Dialog UserDialog 730,91,"IPC-D-356A Netlist Extraction Complete" ' %GRID:10,7,1,1
		GroupBox 20,49,130,35,"Units",.GroupBoxUnits
		Text 40,63,70,14,unitstr,.units
		GroupBox 20,7,690,35,"Filename",.GroupBoxFilename
		Text 30,21,660,14,Filename,.file
		OKButton 610,63,90,21
		PushButton 320,63,110,21,"View Netlist",.ViewButton
	End Dialog
	Dim dlg As UserDialog
	If Dialog( dlg ) = 1 Then
		EndDialog = 1
	Else
		EndDialog = 0
	End If
End Function

Public Filename              ' netlist filename
Public Units                 ' ppcbUnitInch or ppcbUnitMetric
Public UnitF                 ' Multplier provies correct number of digits for each unit setting

'**************** Added 07/04/01 by c.friese
Type DecalType 
	cName As String
	cPinLoc() As String
End Type
'*******************************************

Dim netAliases() As String
Public netAliasCnt

Const Column1 = "3"			' Operation Code
Dim Column2 As String*1			' Operation Code
Const Column3 = "7"			' Operation Code
Dim Column4to20 As String*17	' net name
Dim Column21to26 As String*6	' reference designator
Dim Column27 As String*1		' -
Dim Column28to31 As String*4	' pin number
Dim Column32 As String*1		' M if test is in middle of a net
Dim Column33 As String*1		' D (hole Diameter)
Dim Column34to37 As String*4	' actual hole diameter as 0.00001in or 0.001mm increments
Dim Column38 As String*1		' P = plated, U = unplated
Const Column39 = "A"			' A (access)
Dim Column40to41 As String*2	' access side 00 = both sides, 01 = top side, 0x = other side
Const Column42 = "X"			' X ( x location )
Dim Column43to49 As String*7	' actual x location as 0.00001in or 0.001mm increments
Const Column50 = "Y"			' Y ( y location )
Dim Column51to57 As String*7	' actual y location as 0.00001in or 0.001mm increments
Const Column58 = "X"			' X (feature dimension)
Dim Column59to62 As String*4	' actual x feature dimension
Const Column63 = "Y"			' Y (feature dimension)
Dim Column64to67 As String*4	' actual y feature dimension
Const Column68 = "R"			' R (feature rotation)
Dim Column69to71 As String*3	' actual feature rotation
Dim Column72 As String*1		' ~blank~
Dim Column73 As String*1		' S (solder mask coverage)
Dim Column74 As String*1		' 0 = no sm, 1 = sm primary side, 2 = sm secondary side, 3 = sm both sides
Dim Column75to80 As String*6

' John Brown, Cape CAD Design
' Gary Bankston, Silicon Hills Design
Sub Main
	'====================================================================
	' Set up inital output file name
	If Document.path = "" Then
		MsgBox( "Oops, no database loaded!!! Nothing to do.", vbOkOnly Or vbCritical, "Cannot Continue" )
		Exit All
	End If
	Filename = Document.path & "\" & Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4) & ".ipc"

	'====================================================================
	' Opening Dialog (Sets Filename, Units )
	If StartDialog = 0 Then
		Exit All
	End If

	'====================================================================
	' open output file
	' !!! make sure that the file was opened successfully
	On Error GoTo 0
	On Error GoTo FileOpenErr
	Open Filename For Output As #1
	GoTo NoFileOpenErr
	FileOpenErr:
		MsgBox( "Error - Could not open output file > " & Filename, vbCritical )
		Exit All
	NoFileOpenErr:
	On Error GoTo 0
	
'**************** Added 04/07/01 by c.friese
	ReDim Decals(0)	As DecalType			
	GetDecalPinLocations Decals()
	If MakeDecalArrayDebugFile = True Then DebugDecalArray decals()
	For i = 1 To ActiveDocument.LayerCount
		If ActiveDocument.LayerType(i) > 2 Then
			ElecMaxLayer = i - 1
			Exit For
		End If
	Next i
	
'*******************************************

	LockServer
	
	'====================================================================
	' Start the netlist
	Print #1, "C  Program by Cape CAD Design"
	Print #1, "C  Updated by Silicon Hills Design"
	Print #1, "C  "
	Print #1, "C  Date:" & Now
	Print #1, "C  Database: "& Document.Name
	Print #1, "C  "

	' Header
	Print #1, "P  JOB   " + Document.Name
	' units
	If Units = ppcbUnitMetric Then
		UnitF = 1000
		Print #1, "P  UNITS CUST 1"
	Else
		UnitF = 10000
		Print #1, "P  UNITS CUST 0"
	End If
	' Version
	Print #1, "P  VER IPC-D-356A"
	' primary image
	Print #1, "P  IMAGE PRIMARY"
	
	createNetAliases

	'====================================================================
	' do each net
	Application.StatusBarText = "Creating IPC-D-356 netlist ..."
	Application.ProgressBar = 0
	nc = 0 ' counts nets (used for progressbar)
	netCnt = ActiveDocument.Nets.Count
    For Each aNet In ActiveDocument.Nets
    	' set the progress bar
    	nc = nc + 1
    	Application.ProgressBar = nc * 100 / netCnt

		Column4to20 = getNetname( aNet.Name )
    	
    	' Pins ----------------------------------------------------------
	   	For Each aPin In aNet.Pins
	   		' get the pin data
'**************** Added 04/07/01 by c.friese	   		

	   		If aPin.IsSMD = True Then
		'	If aPin.IsSMD = True And aPin.DrillSize = 0 Then
			
			PinSide = GetPinSide(Decals(), aPin)

'*******************************************
			
				Column2 = "2"
			Else
				Column2 = "1"
			End If
			Column21to26 = aPin.Component
			Column27 = "-"
			Column28to31 = aPin.Number
			Column32 = ""
			If aPin.DrillSize( Units ) > "0" Then
				Column33 = "D"
    			Column34to37 = FormatDrill( aPin.DrillSize( Units ) )
    			If aPin.Plated = True Then
    				Column38 = "P"
    			Else
    				Column38 = "U"
    			End If
    		Else
    			Column33 = ""
    			Column34to37 = ""
    			Column38 = ""
	   		End If
			If aPin.DrillSize( Units ) > "0" Then
				Column40to41 = "00"
			Else
				Column40to41 = PinSide
				
'**************** Comment out by 07/04/01 by c.friese
'				If Apin.Component.layer = "1" Then
'					Column40to41 = "01"                                  ' top side access
'				Else
'					Column40to41 = Format$( Apin.Component.layer, "00" ) ' bottom side access
'				End If
'*******************************************

			End If
			
			Column43to49 = FormatPosition( aPin.PositionX( Units ) )
			Column51to57 = FormatPosition( aPin.PositionY( Units ) )
			' print it out
			Print #1,Column1;
			Print #1,Column2;
			Print #1,Column3;
   			Print #1,Column4to20;
			Print #1,Column21to26;
			Print #1,Column27;
			Print #1,Column28to31;
			Print #1,Column32;
			Print #1,Column33;
			Print #1,Column34to37;
			Print #1,Column38;
			Print #1,Column39;
			Print #1,Column40to41;
			Print #1,Column42;
			Print #1,Column43to49;
			Print #1,Column50;
			Print #1,Column51to57
   		Next

		' Vias ----------------------------------------------------------
		' Start | End | Access | include
		'   t   |  b  |   00   |   yes
		'   t   |  i  |   01   |   yes
		'   i   |  b  |   0x   |   yes
		'   i   |  i  |   --   |   no
		For Each aVia In aNet.Vias
			' determine whether or not this is a Thru, blind or buried via (skip buried vias )
			startlyr = Document.LayerType( aVia.StartLayer )
			endlyr   = Document.LayerType( aVia.EndLayer )
			If ( startlyr =  ppcbLayerComponent ) Or ( endlyr =  ppcbLayerComponent ) Then
				Select Case True
					Case ( startlyr =  ppcbLayerComponent ) And ( endlyr =  ppcbLayerComponent )
						' thru via
						Column40to41 = "00" ' Accessible from Both sides
					Case ( startlyr =  ppcbLayerComponent ) And ( endlyr <> ppcbLayerComponent )
						' blind - Accessible from Top side
						Column40to41 = "01"
					Case ( startlyr <> ppcbLayerComponent ) And ( endlyr =  ppcbLayerComponent )
						' blind - Accessible from Bottom side
						Column40to41 = Format$( aVia.EndLayer, "00" )
					' Case Else (this won't happen do to the previous If
				End Select
				' get the via data
				Column2 = "1"
				Column21to26 = "VIA"
				Column27 = ""
				Column28to31 = ""
				Column32 = ""
				If aVia.DrillSize( Units ) > "0" Then
					Column33 = "D"
					Column34to37 = FormatDrill( aVia.DrillSize( Units ) )
	    			'MsgBox( "drill = " & aPin.DrillSize() & ", " & aPin.DrillSize( Units ) & ", " & FormatDrill( aPin.DrillSize( Units ) ) )
	   				If aVia.Plated = True Then
						Column38 = "P"
					Else
						Column38 = "U"
					End If
	   			Else
					Column33 = ""
					Column34to37 = ""
					Column38 = ""
	   			End If
				Column43to49 = FormatPosition( aVia.PositionX( Units ) )
				Column51to57 = FormatPosition( aVia.PositionY( Units ) )
				' print it out
				Print #1,Column1;
				Print #1,Column2;
				Print #1,Column3;
				Print #1,Column4to20;
				Print #1,Column21to26;
				Print #1,Column27;
				Print #1,Column28to31;
				Print #1,Column32;
				Print #1,Column33;
				Print #1,Column34to37;
				Print #1,Column38;
				Print #1,Column39;
				Print #1,Column40to41;
				Print #1,Column42;
				Print #1,Column43to49;
				Print #1,Column50;
				Print #1,Column51to57
			End If
   		Next
	Next

	'====================================================================
	' Done
	Print #1,"999"
   	Close #1
   	Application.StatusBarText = "Netlist completed"
   	Application.ProgressBar = -1
   	UnlockServer

	'====================================================================
	' closing dialog
'  	MsgBox ( msg, vbOkOnly Or vbInformation, "Netlist Extract Complete" )
	If EndDialog = 1 Then
		'MsgBox( "vewing output" )
		Shell "Notepad " & Filename, 1
	End If

End Sub
'***************************************************************************************************
'***************************************************************************************************
'***************************************************************************************************
'***************************************************************************************************
Function GetPinSide(Decals() As DecalType, pn As Object) As String 
	Dim i%,u$
	Dim Dcl$
	Dim CpLoc$
	Dim BtStr$
	BtStr = Format(ElecMaxLayer,"00")
	CpLoc = Format(pn.Component.layer,"00")
	Dcl = pn.Component.Decal
	For i = 1 To UBound(Decals)
		If Dcl = decals(i).cname Then
			u = decals(i).cpinloc(pn.Number)
			If CpLoc = "01" Then
				If u = "Top" Then
					GetPinSide = "01"
				ElseIf u = "Bottom" Then
					GetPinSide = BtStr
				End If
			Else
				If u = "Top" Then
					GetPinSide = BtStr
				ElseIf u = "Bottom" Then
					GetPinSide = "01"
				End If
			End If
			Exit For
		End If
	Next i
End Function
'***************************************************************************************************
'***************************************************************************************************
'***************************************************************************************************
Sub GetDecalPinLocations(Decals() As DecalType)
	Dim c As Object
	Dim cCount%,x%,i%,y%,t$
	Dim inline$, found%
	Dim j%, lCount%, ActPad%, k%
	Dim n0#
	Dim n2#
	ReDim TxtLines(0) As String
	StatusBarText = "Get Decals..."
'---------------------- ASCII Out Decal Section -------------------	

	ascfile = Document.path & "\" & Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4) & "_decals.asc"
'	ActiveDocument.ExportASCII MacroDir & "\tmp.asc", ppcbASCIISectionDecals		
	ActiveDocument.ExportASCII ascfile, ppcbASCIISectionDecals		
	
'---------------------- Read ASCII Out into a TextArray -----------		

	Open ascfile For Input As #2
		While Not EOF(2)
			Line Input #2, inline 
			AddDynamicArray TxtLines(), inline
		Wend
	Close #2
'	Kill MacroDir & "\tmp.asc"
	Kill ascfile
	
'---------------------- Prepare DecalArray ------------------------

	ReDim tmp(0) As String
	For Each c In ActiveDocument.Components
		t = c.Decal & " " & Str(c.Pins.Count)
		If CheckStringArray(tmp(), t) = False Then AddDynamicArray tmp(), t
	Next c
	
	ReDim Decals(UBound(tmp))
	For i = 1 To UBound(tmp)
		Decals(i).cName = getel(tmp(i), " ",1)
		ReDim Decals(i).cpinLoc(Val(getel(tmp(i), " ",2)))
	Next i
	
'----------------------- Get Pin Location -- ------------------------
	dccount = UBound(Decals)
	For i = 1 To UBound(Decals)
		ProgressBar = i*100/dccount
		With Decals(i)
			For j = 1 To UBound(TxtLines)
				If found = True And TxtLines(j) = "" Then 
					found = False
					Exit For
				End If
				If found = True Then
					If Left(TxtLines(j),3) = "PAD" Then 
						ActPad = Val(getel(TxtLines(j)," ",2))	
						LCount = Val(getel(TxtLines(j)," ",3))	
						For k = j To j + LCount
							If Left(TxtLines(k), 2) = "-2" Then 
								n2 = CDbl(getel(TxtLines(k), " ", 2))
							End If
							If Left(TxtLines(k), 1) = "0" Then 
								n0 = CDbl(getel(TxtLines(k), " ", 2))
							End If
						Next k
						j = j + LCount
						If n2 > 0 Then .cPinLoc(ActPad) = "Top"
						If n0 > 0 Then .cPinLoc(ActPad) = "Bottom"
						If n0 = 0 And n2 = 0 Then .cPinLoc(ActPad) = "0"
					End If
				End If
				If found = False Then
					If .cName = getel(TxtLines(j)," ",1) Then 
						found = True
					End If	
				End If	
			Next j
			For j = 1 To UBound(.cPinLoc)
				If .cPinLoc(j) = "" Then .cPinLoc(j) = .cPinLoc(0)
			Next j
		End With
	Next i
	
	ProgressBar = 0
End Sub
'***************************************************************************************************
'******************************* Standard Routines added by c.friese *******************************
'***************************************************************************************************
'***************************************************************************************************
Sub AddDynamicArray(Ar() As String, NewStr$)
    Dim x%
    x = UBound(Ar) + 1
    ReDim Preserve Ar(x)
    Ar(x) = NewStr
End Sub
'****************************************************************************************************
'****************************************************************************************************
'****************************************************************************************************
Function CheckStringArray(Ar() As String, ChkString$) As Integer
	Dim i%, l%, u%
	l = LBound(ar)
	u = UBound(ar)
	For i = l To u
		If ar(i) = ChkString Then
			CheckStringArray = True
			Exit Function
		End If
	Next i
End Function
'****************************************************************************************************
'****************************************************************************************************
'****************************************************************************************************
Function GetEl(tt$, ch$, el%) As String
    Dim i%, a%, l%, b%, u$, t$
    t = tt
    While Left$(t, 1) = ch
         t = Right$(t, Len(t) - 1)
     Wend
    b = 1
    a = InStr(1, t, ch)
    While a > 0
       If b = el Then GetEl = Left$(t, a - 1): Exit Function
       t = Right$(t, Len(t) - a)
       While Left$(t, 1) = ch
        t = Right$(t, Len(t) - 1)
       Wend
       b = b + 1
       a = InStr(1, t, ch)
    Wend
    If el = b Then GetEl = t
End Function
'****************************************************************************************************
'****************************************************************************************************
'****************************************************************************************************
Sub DebugDecalArray(ar()As decaltype)
	Dim i%,j%
	repfile = Document.path & "\" & Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4) & "_decal.rep"
	Open repfile For Output As #10
		For i = 1 To UBound(ar)
			Print #10,""
			Print #10,"Decal : " & ar(i).cname
			For j = 1 To UBound(ar(i).cpinloc)
				Print #10, vbTab & "Pin " & j & "  -  " & ar(i).cpinloc(j)
			Next j
		Next i
	Close #10
End Sub
'*******************************************************************************************
'*******************************************************************************************
'*******************************************************************************************
Private Function SearchWindowHWnd(SearchString As String) As Long
    Dim x As Long
    Dim y As Long
    Dim t$
    Dim SLen%
    SLen = Len(SearchString)
    x = GetDesktopWindow()
    x = GetWindow(x, 5)
    t = Space$(255)
    y = GetWindowText(x, t, 255)
    	If InStr(1, t, SearchString) > 0 Then
            SearchWindowHWnd = x
            Exit Function
        End If
    While x <> 0
        x = GetWindow(x, 2)
        t = Space$(255)
        y = GetWindowText(x, t, 255)
    	If InStr(1, t, SearchString) > 0 Then
            SearchWindowHWnd = x
            Exit Function
        End If
    Wend
End Function
'*******************************************************************************************
'*******************************************************************************************
'*******************************************************************************************
Function MacroName As String
	Dim x&,y&, t$,i%, cm%
	Dim PadsHwnd&, MHwnd&
	PadsHwnd = SearchWindowHWnd("PowerPCB")
    Y = GetSubMenu(GetMenu(PadsHwnd), 4)                        'Tool Menu
    X = GetMenuItemCount(Y)
    For i = 0 To X
        t = Space(255)
        X = GetMenuString(Y, i, t, 255, MF_BYPOSITION)
        If InStr(1, t, "Basic") > 0 Then
            Y = GetSubMenu(Y, i)
            cm = GetMenuItemCount(Y) - 1
            t = Space(255)
            X = GetMenuString(Y, cm, t, 255, MF_BYPOSITION)
            t = Trim(t)
            t = Left(t, Len(t) - 1)
            If Left(t,5) = "Stop " Then
            'Debug.Print t
            	MacroName = getel(t," ",2)
            	Exit Function
            End If
        End If
    Next i
End Function

IPC-D-356A_Netlist_Extractor.4_7_1.c

/*!
 * \file
 * \brief Generates an IPC-D-356A netlist from a PowerPCB database.
 * \author
 *
 */


/*!
 *\brief formats positon as six digits, will always have a leading "+" or "-".
 *
 * a "." (period) is not always the decimal seperator. \n
 * Europe uses a "," (comma). \n
 * Added a quick fix to detect the comma. This is a bit of a kludge though. \n
 * It will only work for a comma. \n
 * To be a real fix, need some way to find out what the system setting for the decimal seperator is and then subsitute that with a period. \n
 * ACTUALLY - shouldn't VB's val() function detect the system's decimal seperator and just handle this appropriately ? \n
 *
 * \return \c fp.
 */
char * 
format_position (char pos)
{
        if (InStr (pos, ",") == 0)
        {
                 pos = Replace (pos, ",", ".");
        }
        pos = Val (pos);
        if (pos >= 0)
        {
                fp = Format$ ( pos * UnitF, "+000000" );
        }
        else
        {
                fp = Format$( pos * UnitF, "000000" );
        }
        FormatPosition = fp;
        return (fp);
}


/*!
 * \brief If a netname is longer than 14 chars, look up its alias
 * otherwise just return the netname unchanged.
 */
char *
getNetname (char * netname)
{
        If Len (netname) > 14
        {
                /* see if this net already has an alias. */
                for (n = 1, n = netAliasCnt; n++)
                {
                        if (netname == netAliases (n))
                        {
                                getNetname = "NNAME" + Format$ (n);
                                return;
                        }
                }
        }
        else
        {
                getNetname = netname;
                return;
        }
        getNetname = "no_alias_found";
}


/* EOF */