CA Idiot

Move the designator where you click the mouse.

2011-09-21T07:00:00.000-07:00

Click on the component and then click at the location where the designator is to be and it moves the designator to that location.

Sub ClickMoveDesPos

Dim Board
Dim Comp
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

While Board.ChooseLocation(x,y, "Click Via To Change") = True
Set Comp = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
eComponentObject),AllLayers,eEditAction_Focus)

If Not(Comp is Nothing) Then
     Call Board.ChooseLocation(x,y, "Select Location")
     Call PCBServer.PreProcess
     Call PCBServer.SendMessageToRobots(Comp.I_ObjectAddress,_
     c_Broadcast, PCBM_BeginModify, c_NoEventData)

           Comp.ChangeNameAutoposition = eAutoPos_Manual
           Comp.Name.XLocation = x
           Comp.Name.YLocation = y

     Call PCBServer.SendMessageToRobots(Comp.I_ObjectAddress,_
     c_Broadcast, PCBM_EndModify , c_NoEventData)
     Call PCBServer.PostProcess
End If
Wend

ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")
End Sub

www.tdpcb.com

Change the AutoPosition of the designator

2011-09-16T10:44:00.000-07:00

Click on a component and the designator autoposition will cycle around the 8 positions each time you click on the component.

Sub CycleDesPos

Dim Board
Dim Comp
Dim I

Dim eAutoArray
'               0                               1                                 2
'eAutoPos_TopLeft,eAutoPos_CenterLeft,eAutoPos_BottomLeft,
'                  3                                     4                                    5
'eAutoPos_BottomCenter,eAutoPos_BottomRight,eAutoPos_CenterRight,
'                  6                                7
'eAutoPos_TopRight,eAutoPos_TopCenter
eAutoArray = Array(1,2,3,6,9,8,7,4)

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Call PCBServer.PreProcess
While Board.ChooseLocation(x,y, "Click Via To Change") = True
Set Comp = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
eComponentObject),AllLayers,eEditAction_Focus)
I= -1

   If Not(Comp is Nothing) Then

     'Look for the current setting of the autoposition
     For J = 0 to 7
      If Comp.NameAutoposition = eAutoArray(J) Then
          I = J + 1
          'Set the array to begin again at eAutoPos_TopLeft
          If J = 7 Then
             I = 0
          End If
      End If
     Next
     'Autoposition is either manual or centercenter
     If I = -1 Then
         I = 0
     End If

     Call PCBServer.SendMessageToRobots(Comp.I_ObjectAddress,_
     c_Broadcast, PCBM_BeginModify, c_NoEventData)

           Comp.ChangeNameAutoposition = eAutoArray(I)

     Call PCBServer.SendMessageToRobots(Comp.I_ObjectAddress,_
     c_Broadcast, PCBM_EndModify , c_NoEventData)

End If

Wend

Call PCBServer.PostProcess

ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Clone a vias net to another via

2011-09-15T13:55:00.000-07:00

This required a few months of help from Altium, they didn't solve the problem of not being able to add a net to an exsisting via with "not net". But Altium did put me on the right path, the via with "no net" has to be added to the net object, not adding the net to the via (which works if the via already has a net). So this fixes the previous scripts inability to add a net to a via with "no net".

Sub CloneViaNetOBJ
Dim Board
Dim ObjVia
Dim Borg

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
Set ObjVia = Board.GetObjectAtCursor(MkSet(eViaObject)_
,AllLayers,"Select Via to Clone")

NetIterator = Board.BoardIterator_Create
NetIterator.AddFilter_ObjectSet(MkSet(eNetObject))
NetIterator.AddFilter_LayerSet(AllLayers)
NetIterator.AddFilter_Method(eProcessAll)
Set NetFound = NetIterator.FirstPCBObject

While FoundIt = 0 AND Not (NetFound Is Nothing)
      If NetFound.Name = ObjVia.Net.Name Then
         FoundIt = 1
      else
          Set NetFound = NetIterator.NextPCBObject
      End If
Wend

Call PCBServer.PreProcess
While Board.ChooseLocation(x,y, "Click Via To Change") = True
Set Borg = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
eViaObject),AllLayers,eEditAction_Focus)

If Not(Borg is Nothing) Then
     Call PCBServer.SendMessageToRobots(Borg.I_ObjectAddress,_
     c_Broadcast, PCBM_BeginModify, c_NoEventData)
     'Need to add the via to the net group, not the other way around!
        NetFound.AddPCBObject(borg)
     Call PCBServer.SendMessageToRobots(Borg.I_ObjectAddress,_
     c_Broadcast, PCBM_EndModify , c_NoEventData)
End If
Wend

Call Board.CleanNet(NetFound) 'How to clean all nets?
Call PCBServer.PostProcess
ResetParameters
Board.BoardIterator_Destroy(NetIterator)
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")
End Sub

Click the via with the net that you want

Then click the ones you want to change.

www.tdpcb.com

List of Altium Shortcut keys

2011-07-22T21:34:00.000-07:00

http://wiki.altium.com/display/ADOH/Editor+Shortcuts

www.tdpcb.com

Covert net labels to text Labels and vice versa

2011-07-14T21:01:00.000-07:00

Click on a text label and it will be converted to a net label, click on a text label on it will be converted to a net label.

Sub Label2Text

If SchServer Is Nothing Then Exit Sub
Set CurrentSheet = SchServer.GetCurrentSchDocument
If CurrentSheet is Nothing Then Exit Sub

Call SchServer.ProcessControl.PreProcess(CurrentSheet, "")
Set Alocation = CurrentSheet.Location

While CurrentSheet.ChooseLocationInteractively(Alocation,"Select Label")

Set HitTest = CurrentSheet.CreateHitTest(eHitTest_AllObjects, ALocation)

If (HitTest.HitTestCount > 0) Then
For I = 0 to (HitTest.HitTestCount-1)

    If HitTest.HitObject(I).ObjectId = eLabel Then
      Set SchLabel = SchServer.SchObjectFactory(eNetLabel,eCreate_GlobalCopy)
      SchLabel.FontID = HitTest.HitObject(I).FontID
      Schlabel.Text = HitTest.HitObject(I).Text
      Schlabel.Location = HitTest.HitObject(I).Location
      CurrentSheet.RegisterSchObjectInContainer(SchLabel)
      CurrentSheet.GraphicallyInvalidate
      CurrentSheet.RemoveSchObject(HitTest.HitObject(I))
      Call SchServer.RobotManager.SendMessage(CurrentSheet.I_ObjectAddress,_
      c_BroadCast,SCHM_PrimitiveRegistration,HitTest.HitObject(I).I_ObjectAddress)

    ElseIf HitTest.HitObject(I).ObjectId = eNetLabel Then

      Set SchLabel = SchServer.SchObjectFactory(eLabel,eCreate_GlobalCopy)
      SchLabel.FontID = HitTest.HitObject(I).FontID
      Schlabel.Text = HitTest.HitObject(I).Text
      Schlabel.Location = HitTest.HitObject(I).Location
      CurrentSheet.RegisterSchObjectInContainer(SchLabel)
      CurrentSheet.RemoveSchObject(HitTest.HitObject(I))
      CurrentSheet.GraphicallyInvalidate
      Call SchServer.RobotManager.SendMessage(CurrentSheet.I_ObjectAddress,_
      c_BroadCast,SCHM_PrimitiveRegistration,HitTest.HitObject(I).I_ObjectAddress)

    End If

Next

End If
Wend

Call SchServer.ProcessControl.PostProcess(CurrentSheet, "")
CurrentSheet.GraphicallyInvalidate

End Sub

www.tdpcb.com

Loop while getting location with ChooseLocationInteractively

2011-07-05T07:49:00.000-07:00

How to set up a loop while keeping the cursor active.

Sub LoopIt

If SchServer Is Nothing Then Exit Sub
Set CurrentSheet = SchServer.GetCurrentSchDocument
If CurrentSheet is Nothing Then Exit Sub
Set Alocation = CurrentSheet.Location

While CurrentSheet.ChooseLocationInteractively(Alocation,"Select Label")
'tempStr = LocationtoStr(Alocation)
ShowMessage("Location: " & CoordToMils(Alocation.X)_
& "," & CoordToMils(Alocation.Y))

Wend

www.tdpcb.com

End Sub

Hit Test Usage for Schematic

2011-06-30T16:51:00.000-07:00

Using the ChooseLocationInteractively function to determine what is located at the cursor location when it is clicked. The HitTest stores all of the objects located at the cursor when clicked.

Sub HitTestExample

If SchServer Is Nothing Then Exit Sub
Set CurrentSheet = SchServer.GetCurrentSchDocument
If CurrentSheet is Nothing Then Exit Sub

Set Alocation = CurrentSheet.Location
Call CurrentSheet.ChooseLocationInteractively(Alocation,"Select Label")
Set HitTest = CurrentSheet.CreateHitTest(eHitTest_AllObjects, ALocation)

If (HitTest.HitTestCount > 0) Then
   For I = 0 to (HitTest.HitTestCount-1)
      ShowMessage ("ObjectID Is " & HitTest.HitObject(I).ObjectId)
   Next

End If

End Sub

www.tdpcb.com

Renumbering PCB pads with a mouse click

2011-06-17T09:00:00.000-07:00

Quick way to renumber pads, mostly useful in the pcb library editor.
Click on the pad with the first number and then click on the other pads and they will incremently change numbers.

Sub RenumberPads

Dim Board
Dim Rpad
Dim PadNumber

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
Pcbserver.PreProcess
Set PadObject = Board.GetObjectAtCursor(MkSet(ePadObject),_
AllLayers,"Select Pad To Start With")
PadNumber = PadObject.Name + 1

While Board.ChooseLocation(x,y, "Click Next Pad To Renumber") = True
Set Rpad = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
ePadObject),AllLayers,eEditAction_Change)

If Not(Rpad is Nothing) Then
     Call PCBServer.SendMessageToRobots(Rpad.I_ObjectAddress,_
     c_Broadcast, PCBM_BeginModify, c_NoEventData)

     Rpad.Name = PadNumber

     Call PCBServer.SendMessageToRobots(Rpad.I_ObjectAddress,_
     c_Broadcast, PCBM_EndModify , c_NoEventData)
End If

PadNumber = PadNumber + 1
Wend

Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Via Rules

2011-06-15T06:00:00.000-07:00

Get the details of the via routing style rule.

Sub GetViaRule

Dim Board
Dim tmpStr

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eRuleObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)
Set Rule = Iterator.FirstPCBObject

While Not (Rule Is Nothing)

If Rule.Rulekind = eRule_RoutingViaStyle Then
tmpStr = "Name: " & Rule.Name & vbcrlf
tmpStr = tmpStr & "Pref Via Width: " & CoordtoMils(Rule.PreferedWidth)
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Min Via Width: " & CoordtoMils(Rule.MinWidth)
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Max Via Width: " & CoordtoMils(Rule.MaxWidth)
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Pref Via Hole Width: " & CoordtoMils(Rule.PreferedHoleWidth)
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Min Via Hole Width: " & CoordtoMils(Rule.MinHoleWidth)
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Max Via Hole Width: " & CoordtoMils(Rule.MaxHoleWidth)
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Scope1: " & Rule.Scope1Expression & vbcrlf
tmpStr = tmpStr & "Scope2: " & Rule.Scope2Expression
ShowMessage( tmpStr )
End If

Set Rule = Iterator.NextPCBObject
Wend

Board.BoardIterator_Destroy(Iterator)
End Sub

www.tdpcb.com

PCB rules and how to access them.

2011-06-13T06:00:00.000-07:00

Get access to the PCB rules. Get the width rules and list the details.

Sub GetWidthRule

Dim Board
Dim tmpStr

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eRuleObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)
Set Rule = Iterator.FirstPCBObject

While Not (Rule Is Nothing)
If Rule.Rulekind = eRule_MaxMinWidth Then
tmpStr = "Name: " & Rule.Name & vbcrlf
tmpStr = tmpStr & "Preferred: " & CoordtoMils(Rule.FavoredWidth(eTopLayer))
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Minimum: " & CoordtoMils(Rule.MinWidth(eTopLayer))
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Maximum: " & CoordtoMils(Rule.MaxWidth(eTopLayer))
tmpStr = tmpStr & "mils" & vbcrlf
tmpStr = tmpStr & "Scope1: " & Rule.Scope1Expression & vbcrlf
tmpStr = tmpStr & "Scope2: " & Rule.Scope2Expression
ShowMessage( tmpStr )
End If
Set Rule = Iterator.NextPCBObject
Wend

Board.BoardIterator_Destroy(Iterator)

End Sub

www.tdpcb.com

A list of available rules:

eRule_Clearance,
eRule_ParallelSegment,
eRule_MaxMinWidth,
eRule_MaxMinLength,
eRule_MatchedLengths,
eRule_DaisyChainStubLength,
eRule_PowerPlaneConnectStyle,
eRule_RoutingTopology,
eRule_RoutingPriority,
eRule_RoutingLayers,
eRule_RoutingCornerStyle,
eRule_RoutingViaStyle,
eRule_PowerPlaneClearance,
eRule_SolderMaskExpansion,
eRule_PasteMaskExpansion,
eRule_ShortCircuit,
eRule_BrokenNets,
eRule_ViasUnderSMD,
eRule_MaximumViaCount,
eRule_MinimumAnnularRing,
eRule_PolygonConnectStyle,
eRule_AcuteAngle,
eRule_ConfinementConstraint,
eRule_SMDToCorner,
eRule_ComponentClearance,
eRule_ComponentRotations,
eRule_PermittedLayers,
eRule_NetsToIgnore,
eRule_SignalStimulus,
eRule_Overshoot_FallingEdge,
eRule_Overshoot_RisingEdge,
eRule_Undershoot_FallingEdge,
eRule_Undershoot_RisingEdge,
eRule_MaxMinImpedance,
eRule_SignalTopValue,
eRule_SignalBaseValue,
eRule_FlightTime_RisingEdge,
eRule_FlightTime_FallingEdge,
eRule_LayerStack,
eRule_MaxSlope_RisingEdge,
eRule_MaxSlope_FallingEdge,
eRule_SupplyNets,
eRule_MaxMinHoleSize,
eRule_TestPointStyle,
eRule_TestPointUsage

Swap Component Positions

2011-06-08T11:25:00.000-07:00

This will swap the positions of two components that are choosen, including the rotation of the part and the rotation and position of the designators. Based on a script that came with Summer '09 but more useful. If a component is not selected the script will end to avoid a crash.

Sub SwapComps

Dim Board
Dim CompA
Dim CompB
Dim CompX
Dim CompY
Dim CompR
Dim DesX
Dim DesY
Dim DesR

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
Pcbserver.PreProcess

While Board.ChooseLocation(x,y, "Select First Componet") = True

Set CompA = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(eComponentObject)_
,AllLayers, eEditAction_Select)
If CompA Is Nothing Then Exit Sub 'Needed, if no comp is selected, crash

   Call Board.ChooseLocation(x,y, "Select Second Componet")
Set CompB = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(eComponentObject)_
,AllLayers, eEditAction_Select)
If CompB Is Nothing Then Exit Sub 'Needed, if no comp is selected, crash

   CompX = CompA.X
   CompY = CompA.Y
   CompR = CompA.Rotation
   DesX = CompA.Name.XLocation
   DesY = CompA.Name.YLocation
   DesR = CompA.Name.Rotation

   Call PCBServer.SendMessageToRobots(CompA.I_ObjectAddress,c_Broadcast,_
   PCBM_BeginModify, c_NoEventData)
   CompA.X = CompB.X
   CompA.Y = CompB.Y
   CompA.Rotation = CompB.Rotation
   CompA.ChangeNameAutoposition = eAutoPos_Manual
   Call PCBServer.SendMessageToRobots(CompA.I_ObjectAddress,c_Broadcast,_
   PCBM_EndModify , c_NoEventData)

   Call PCBServer.SendMessageToRobots(CompA.Name.I_ObjectAddress, c_Broadcast,_
   PCBM_BeginModify, c_NoEventData)
   CompA.Name.XLocation = CompB.Name.XLocation
   CompA.Name.YLocation = CompB.Name.YLocation
   CompA.Name.Rotation = CompB.Name.Rotation
   Call PCBServer.SendMessageToRobots(CompA.Name.I_ObjectAddress, c_Broadcast,_
   PCBM_EndModify , c_NoEventData)

   Call PCBServer.SendMessageToRobots(CompB.I_ObjectAddress,c_Broadcast,_
   PCBM_BeginModify, c_NoEventData)
   CompB.X = CompX
   CompB.Y = CompY
   CompB.Rotation = CompR
   CompB.ChangeNameAutoposition = eAutoPos_Manual
   Call PCBServer.SendMessageToRobots(CompB.I_ObjectAddress,c_Broadcast,_
   PCBM_EndModify , c_NoEventData)

   Call PCBServer.SendMessageToRobots(CompB.Name.I_ObjectAddress, c_Broadcast,_
    PCBM_BeginModify, c_NoEventData)
   CompB.Name.XLocation = DesX
   CompB.Name.YLocation = DesY
   CompB.Name.Rotation = DesR
   Call PCBServer.SendMessageToRobots(CompB.Name.I_ObjectAddress, c_Broadcast,_
    PCBM_EndModify , c_NoEventData)

Wend

Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Set the DRC error for a component

2011-06-06T20:26:00.000-07:00

Simple test to look for the "R2" componet and set it's DRC flag.

Sub SetDRC

Dim Board
Dim CompDes
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eComponentObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessComponents)
Set CompDes = Iterator.FirstPCBObject
PCBServer.PreProcess

While Not(CompDes Is Nothing)
If CompDes.Name.Text = "R2" then
CompDes.SetState_DRCError = True
End If
Set CompDes = Iterator.NextPCBObject
Wend

Board.BoardIterator_Destroy(Iterator)
Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Clone a net from one object to another

2011-06-03T09:04:00.000-07:00

I can see this one as being a little dangerous, it's meant to show how to click an object with a net and then any pad, via, or track that you click (that already has a net assigned) will then be changed to the first net that was choosen.

Sub CloneNet

Dim Board
Dim NetObject
Dim Borg

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

NetObject = Board.GetObjectAtCursor(MkSet(ePadObject,eTrackObject,eViaObject)_
,AllLayers,"Select Net to Clone")
Call PCBServer.PreProcess
While Board.ChooseLocation(x,y, "Click Item To Change") = True

Set Borg = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
ePadObject,eTrackObject,eViaObject),AllLayers,eEditAction_Change)

If Not(Borg is Nothing) Then
     Call PCBServer.SendMessageToRobots(Borg.I_ObjectAddress,_
     c_Broadcast, PCBM_BeginModify, c_NoEventData)

     Borg.Net = NetObject.Net

     Call PCBServer.SendMessageToRobots(Borg.I_ObjectAddress,_
     c_Broadcast, PCBM_EndModify , c_NoEventData)
End If
Wend

Call PCBServer.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Count selected objects

2011-06-01T15:19:00.000-07:00

How many objects are currently selected on the PCB.

Sub CountSelObj
Dim Board

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

ShowMessage (Board.SelectecObjectCount & " Items are selected.")

End Sub

www.tdpcb.com

Toggle Component Designators

2011-05-26T11:03:00.000-07:00

Toggle all component designators on PCB from shown to hidden.

Sub ToggleDesignators

Dim Board
Dim Component

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eComponentObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)
Set Component= Iterator.FirstPCBObject
PCBServer.PreProcess

While Not(Component is Nothing)
Component.NameOn = Not(Component.NameOn)
Set Component= Iterator.NextPCBObject
Wend

Board.BoardIterator_Destroy(Iterator)
Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Open a text file and read the contents line by line.

2011-05-24T14:33:00.000-07:00

As written this needs to be run with a PCB file active.

Sub ReadTextFile

'Constants for File Handling
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TristateUseDefault = -2
Const TristateTrue = -1
Const TristateFalse = 0
Dim Board
Dim FileName
Dim oFS
Dim oFile
Dim oStream

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

'File Handling - Place a text file named "TextFile.txt" in
'the same directory as the current board that is open.
FileName=Left(Board.FileName, InstrRev(Board.FileName, "\") ) & "TextFile.txt"

'Check for the text file
If Not FileExists(FileName) Then
   ShowMessage ( FileName & " was not found.")
   Exit Sub
End If
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFile = oFS.GetFile(FileName)
Set oStream = oFile.OpenAsTextStream(ForReading, TristateUseDefault)

I = 1
'Read the file in
Do While Not oStream.AtEndOfStream
      sRecord = oStream.ReadLine
      ShowMessage ( "Line #" & I & " " & sRecord )
      I = I + 1
Loop
oStream.Close

End Sub

www.tdpcb.com

Place a track and via with the choosen pad net assigned to them.

2011-05-20T06:48:00.000-07:00

Select a pad with a net and a stinger (a track and a via) will be placed with the pads net.

Sub TagPadWithNet

Dim Board
Dim Track
Dim Via
Dim NetObject
Dim PadX
Dim PadY
Dim PadNet
Dim ViasSize
Dim ViaHole

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

NetObject = Board.GetObjectAtCursor(MkSet(ePadObject),AllLayers,"Select Net")
PadX = CoordToMils(NetObject.X)
PadY = CoordToMils(NetObject.Y)
PadNet = NetObject.Net.Name
X1 = PadX
X2 = PadX - CoordToMils(NetObject.TopXSize) - 10
Y1 = PadY
Y2 = PadY
Layer = NetObject.Layer
Width = 10
Call PCBServer.PreProcess

'Add the Track
Track           = PCBServer.PCBObjectFactory(eTrackObject, eNoDimension, eCreate_Default)
Track.X1        = MilsToCoord(X1)
Track.X2        = MilsToCoord(X2)
Track.Y1        = MilsToCoord(Y1)
Track.Y2        = MilsToCoord(Y2)
Track.Layer     = Layer
Track.Net       = NetObject.Net
Track.Width     = MilsToCoord(Width)
Board.AddPCBObject(Track)
Call PCBServer.SendMessageToRobots(Board.I_ObjectAddress,_
c_Broadcast, PCBM_BoardRegisteration, Track.I_ObjectAddress)

'Add the via
ViaSize = 26
ViaHole = 12
Via           = PCBServer.PCBObjectFactory(eViaObject, eNoDimension, eCreate_Default)
Via.X         = MilsToCoord(X2)
Via.Y         = MilsToCoord(Y2)
Via.Size      = MilsToCoord(ViaSize)
Via.HoleSize = MilsToCoord(ViaHole)
Via.LowLayer = eTopLayer
Via.HighLayer = eBottomLayer
Via.Net       = NetObject.Net
Board.AddPCBObject(Via)
Call PCBServer.SendMessageToRobots(Board.I_ObjectAddress,_
c_Broadcast, PCBM_BoardRegisteration, Via.I_ObjectAddress)

Call PCBServer.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

www.tdpcb.com

Get the board dimensions as defined by the board outline.

2011-05-19T06:39:00.000-07:00

Sub BoardDimension
Dim Board
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

ShowMessage ( "X=" & CoordToMils(Board.BoardOutline.BoundingRectangle.right _
- Board.BoardOutline.BoundingRectangle.left) & " mils,Y=" & _
CoordToMils(Board.BoardOutline.BoundingRectangle.top _
- Board.BoardOutline.BoundingRectangle.bottom) & " mils")

End Sub

www.tdpcb.com

Identify a pads net.

2011-05-18T07:00:00.000-07:00

Simple way to get a pads net.

Sub GetPadNet

Dim Board
Dim NetObject
Dim tmpString
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

NetObject = Board.GetObjectAtCursor(MkSet(ePadObject),AllLayers,"Select Net")
tmpString = NetObject.Net.Name
ShowMessage (tmpString)

End Sub

www.tdpcb.com

Report a list of net names in PCB to a file.

2011-05-16T10:22:00.000-07:00

Get a list of net names in the PCB and write a report (text file).

Sub ReportNets

Dim Board
Dim FileName
Dim ReportFile
Dim ReportDocument
Dim fso

BeginHourGlass
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

FileName = Left(Board.FileName, InstrRev(Board.FileName, "\") ) & "ReportNets.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ReportFile = fso.CreateTextFile(FileName, True)

NetIterator = Board.BoardIterator_Create
NetIterator.AddFilter_ObjectSet(MkSet(eNetObject))
NetIterator.AddFilter_LayerSet(AllLayers)
NetIterator.AddFilter_Method(eProcessAll)
Set NetFound = NetIterator.FirstPCBObject

While Not (NetFound Is Nothing)
     Call ReportFile.WriteLine( NetFound.Name )
     Set NetFound = NetIterator.NextPCBObject
Wend

Board.BoardIterator_Destroy(NetIterator)
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")
ReportFile.Close
Set ReportDocument = Client.OpenDocument("Text", FileName)
If Not (ReportDocument Is Nothing) Then
       Client.ShowDocument(ReportDocument)
End If
EndHourGlass

End Sub

www.tdpcb.com

Basic's to write a report text file.

2011-05-14T16:18:00.000-07:00

Run this with a PCB file active.
Sub WriteFile

Dim FileName
Dim ReportDocument
Dim fso
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
'Run With a PCB file open

FileName = Left(Board.FileName, InstrRev(Board.FileName, "\") ) & "temp.Txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ReportFile = fso.CreateTextFile(FileName, True)

Call ReportFile.WriteLine (Now)
Call ReportFile.WriteLine ("Report File Example")

ReportFile.Close
Set ReportDocument = Client.OpenDocument("Text", FileName)
If Not (ReportDocument Is Nothing) Then
Client.ShowDocument(ReportDocument)
End If

End Sub

www.tdpcb.com

Get pads that make up a component using a group iterator.

2011-05-13T11:33:00.000-07:00

Select a PCB component with the GetObject and then using a Group Iterator list all pads and the location of the pads that make up the choosen component.

Sub GetCompPads

Dim Board
Dim Comp
Dim CompGroup
Dim CompPads
Dim x,y
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
While Board.ChooseLocation(x,y, "Choose Pad") = True
      Set Comp = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
      eComponentObject),AllLayers,eEditAction_Focus)

      If Not(Comp is Nothing) Then
         Set CompGroup = Comp.GroupIterator_Create
         CompGroup.AddFilter_ObjectSet(MkSet(EpadObject))
         Set CompPad = CompGroup.FirstPCBObject

         While Not(CompPad is Nothing )
           ShowMessage("Pad=" & CompPad.Name & " X=" & CoordToMils(CompPad.X)_
           & " Y=" & CoordToMils(CompPad.Y))
           Set CompPad = CompGroup.NextPCBObject
          Wend

      End If
Wend

End Sub

www.tdpcb.com

Rotate and Center Designators of Selected Parts.

2011-05-09T21:29:00.000-07:00

Build upon a previous script, rotate and center designators for only selected parts.

Sub RotateSelectedDesignators

Dim Board
Dim Component
Dim CompDes
Dim I
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
BeginHourGlass
Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eComponentObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)
Set CompDes = Iterator.FirstPCBObject
PCBServer.PreProcess
I = 0

While Not (CompDes Is Nothing)

If CompDes.Selected = True Then
    Call PCBServer.SendMessageToRobots(CompDes.Name.I_ObjectAddress,_
    c_Broadcast, PCBM_BeginModify, c_NoEventData)
    I = I + 1
    If CompDes.Layer = eTopLayer then           'Component is on the top
       Select Case CompDes.Rotation
           Case 0, 180, 360
                CompDes.Name.Rotation = 0
           Case 90, 270
                CompDes.Name.Rotation = 90
       End Select
       else                                     'Component is on the bottom
       Select Case CompDes.Rotation
           Case 0, 180, 360
                CompDes.Name.Rotation = 0
           Case 90, 270
                CompDes.Name.Rotation = 270
       End Select
    End If
       Call PCBServer.SendMessageToRobots(CompDes.Name.I_ObjectAddress,_
       c_Broadcast, PCBM_EndModify , c_NoEventData)
       Call PCBServer.SendMessageToRobots(CompDes.Name.I_ObjectAddress,_
       c_Broadcast, PCBM_BeginModify, c_NoEventData)
       CompDes.ChangeNameAutoposition = eAutoPos_CenterCenter
       Call PCBServer.SendMessageToRobots(CompDes.Name.I_ObjectAddress,_
       c_Broadcast, PCBM_EndModify , c_NoEventData)
End if
       Set CompDes = Iterator.NextPCBObject
Wend

'Uncomment this line if you want a message after it has finished.
'ShowMessage(I & " were found")
If I = 0 then
   ShowMessage("No parts were selected.")
End If
Board.BoardIterator_Destroy(Iterator)
Pcbserver.PostProcess
EndHourGlass
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")
End Sub

www.tdpcb.com

GetObject at cursor to pick a component.

2011-05-05T09:01:00.000-07:00

Using the GetObject to choose what component to reset the designator to center/center.
Press escape to end action.

Sub ChooseDesReset

Dim Board
Dim Comp
Dim x,y

Set Board = PCBServer.GetCurrentPCBBoard
Call PCBServer.PreProcess

While Board.ChooseLocation(x,y, "Choose Component") = True
Set Comp = Board.GetObjectAtXYAskUserIfAmbiguous(x,y,MkSet(_
eComponentObject),AllLayers,eEditAction_Focus)

If Not(Comp is Nothing) Then
     Call PCBServer.SendMessageToRobots(Comp.Name.I_ObjectAddress,_
     c_Broadcast, PCBM_BeginModify, c_NoEventData)
     Comp.ChangeNameAutoposition = eAutoPos_CenterCenter
     Call PCBServer.SendMessageToRobots(Comp.Name.I_ObjectAddress,_
     c_Broadcast, PCBM_EndModify , c_NoEventData)
  End If
Wend

Call PCBServer.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

http://www.tdpcb.com/

Selected Components

2011-05-03T09:39:00.000-07:00

Count how many components are currently selected in the PCB.

Sub HowManyCompsSelected

Dim Board
Dim Component
Dim I

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eComponentObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)

Set Component= Iterator.FirstPCBObject
PCBServer.PreProcess
I = 0

While Not(Component is Nothing)

If Component.Selected = True Then
I = I + 1
End If
Set Component= Iterator.NextPCBObject

Wend
ShowMessage(I & " selected.")
Board.BoardIterator_Destroy(Iterator)
Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

http://www.tdpcb.com/

Moving Designators

2011-04-29T17:08:00.000-07:00

Rotate the designators in one of two ways and center them on the component so they are consistant.
Also detect if the component is on the top or the bottom.

Sub RotateDesignators
Dim Board
Dim Component
Dim CompDes
Dim I
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(eComponentObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)

Set CompDes = Iterator.FirstPCBObject
PCBServer.PreProcess
I = 0
While Not (CompDes Is Nothing)
Call PCBServer.SendMessageToRobots(CompDes.Name.I_ObjectAddress,_
c_Broadcast, PCBM_BeginModify, c_NoEventData)
I = I + 1
If CompDes.Layer = eTopLayer then           'Component is on the top
    Select Case CompDes.Rotation
    Case 0, 180, 360
       CompDes.Name.Rotation = 0
    Case 90, 270
       CompDes.Name.Rotation = 90
    Case Else
       CompDes.Name.Rotation = 0
    End Select
Else                                     'Component is on the bottom
   Select Case CompDes.Rotation
    Case 0, 180, 360
       CompDes.Name.Rotation = 0
    Case 90, 270
       CompDes.Name.Rotation = 270
    Case Else
       CompDes.Name.Rotation = 0
    End Select
End If

CompDes.ChangeNameAutoposition = eAutoPos_CenterCenter
Call PCBServer.SendMessageToRobots(CompDes.Name.I_ObjectAddress,_
c_Broadcast, PCBM_EndModify , c_NoEventData)

Set CompDes = Iterator.NextPCBObject
Wend
'Uncomment next line if you want a message after it has finished.
'ShowMessage(I & " were found")
Board.BoardIterator_Destroy(Iterator)
Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")
End Sub

http://www.tdpcb.com/

File Name On Visible Layers

2011-04-29T17:07:00.001-07:00

Create a sting from the PCB file name and place it on the board but leave off the ending (.pcbdoc). It will place a string on any routing and mechanical layer that is currently enabled and is visible.

Sub AddFileName

Dim Board
Dim ASMSting
Dim Layer
Dim TmpString
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
PCBServer.PreProcess

For Layer = eTopLayer to eMultiLayer
If Board.LayerIsDisplayed(Layer) AND Board.LayerIsUsed(Layer) Then
   ASMString = PCBServer.PCBObjectFactory(eTextObject,_
eNoDimension, eCreate_Default)
ASMString.XLocation = Board.XOrigin + MilsToCoord(500) '500 mils from origin in X
ASMString.YLocation = Board.YOrigin - MilsToCoord(500) '-500 mils from origin in Y
TmpString = Board.FileName
'Get rid of the drive and folder portion of the FileName
  While Instr(TmpString, "\") <> 0
    TmpString = Right(TmpString, Len(TmpString)-Instr(TmpString, "\") ) 'removes the path
  Wend

ASMString.Text = Left(TmpString, Instr(TmpString, ".") - 1 ) 'removes the extension
ASMString.Size = MilsToCoord(100) 'Size of the string is 10
ASMString.Layer = Layer

Board.AddPCBObject(ASMString) ' Put this string on the Board
Call PCBServer.SendMessageToRobots(ASMString.I_ObjectAddress, c_Broadcast,_

PCBM_BoardRegisteration, ASMString.I_ObjectAddress)

End If

Next
Pcbserver.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

http://www.tdpcb.com/

Make A String

2011-04-29T17:07:00.000-07:00

Create a sting of various heights and widths on the PCB.

Sub StringCreation

Dim Board
Dim ASMSting

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub

PCBServer.PreProcess
For I = 1 to 10
' Create a String object
ASMString = PCBServer.PCBObjectFactory(eTextObject, eNoDimension, eCreate_Default)
ASMString.XLocation = Board.XOrigin + I*MilsToCoord(50)
ASMString.YLocation = Board.YOrigin + I*MilsToCoord(100)
ASMString.Layer = eMechanical7
ASMString.Text = "This Is String #" & I & " with a height of " & (10*I) & " a width of " & I & "mils."
ASMString.Width = MilsToCoord(I)
ASMString.Size = MilsToCoord(10 * I)

Call PCBServer.SendMessageToRobots(ASMString.I_ObjectAddress, c_Broadcast,_
PCBM_BoardRegisteration, ASMString.I_ObjectAddress)

'Put this string on the Board
Board.AddPCBObject(ASMString)
Next

PCBServer.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

http://www.tdpcb.com/

Create a Schematic pin in a library part

2011-04-29T14:37:00.000-07:00

Places a pin in a schematic library part. Open a schematic library (or create a new one.) Run script and in the current part a pin will be placed.

Sub PlacePin

Set CurrentLib = SchServer.GetCurrentSchDocument
If CurrentLib is Nothing Then Exit Sub
If CurrentLib.ObjectID <> eSchLib Then Exit Sub

Set SchComponent = SchServer.SchObjectFactory(eSchComponent, eCreate_Default)
'Set up parameters for the library component.
SchComponent.CurrentPartID = 1
SchComponent.DisplayMode = 0

'Create pin objects for the new library component.
P1 = SchServer.SchObjectFactory(ePin,eCreate_GlobalCopy)

If P1 is Nothing Then Exit Sub
'Define the pin parameters.
P1.Location = Point(MilsToCoord(250), MilsToCoord( -250 ))
P1.Orientation = eRotate180
P1.PinLength = MilsToCoord(250)
P1.Designator = "1"
P1.Name = "Pin Name"
P1.Electrical = Etype(4) '4=Passive
P1.OwnerPartId = CurrentLib.CurrentSchComponent.CurrentPartID
P1.OwnerPartDisplayMode = CurrentLib.CurrentSchComponent.DisplayMode

SchComponent.AddSchObject(P1)
CurrentLib.RegisterSchObjectInContainer(P1)

'Send a system notification that a new component has been added to the library.
Call AddStringParameter("Action", "Redraw")
RunProcess("SCH:Zoom")

Call SchServer.RobotManager.SendMessage(nil, c_BroadCast, SCHM_PrimitiveRegistration,_ SCHComponent.I_ObjectAddress)

Set CurrentLib.CurrentSchComponent = SchComponent
'Refresh library.
CurrentLib.GraphicallyInvalidate

End Sub

============================
FYI - Electrical definitions for the pin type:
0=Input
1=I/O
2=Output
3=Open Collector
4=Passive
5=HiZ
6=Open Emitter
7=Power

http://www.tdpcb.com/

Is this a schematic file?

2011-04-27T16:32:00.000-07:00

Checking if the active file is a schematic document.

Sub IsthisaSCHFile

Set CurrentFile = SchServer.GetCurrentSchDocument
If CurrentFile is Nothing Then
ShowMessage ("This is not a SCH file!")
Else
ShowMessage ("This is a SCH file!")
End If

End Sub

http://www.tdpcb.com/

Counting Pads

2011-04-19T15:24:00.000-07:00

Learn to use an Iterator that creates a set of objects that meet a certain criteria. This will count the number of pads on the board. Use the AddFilter's to include only the objects that you need.

Sub CountPads
Dim Board
Dim Pad
Dim PadNumber
Dim TotalObjects

Padnumber = 0
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
Iterator = Board.BoardIterator_Create
Iterator.AddFilter_ObjectSet(MkSet(ePadObject))
Iterator.AddFilter_LayerSet(AllLayers)
Iterator.AddFilter_Method(eProcessAll)

Set Pad = Iterator.FirstPCBObject

While Not (Pad Is Nothing)
PadNumber = PadNumber + 1
Set Pad = Iterator.NextPCBObject
Wend

Board.BoardIterator_Destroy(Iterator)
ShowMessage(PadNumber & " Were Found")

End Sub

http://www.tdpcb.com/

Create a Via

2011-04-17T10:20:00.000-07:00

Make a few Vias appear on a PCB with the reference being the Board Origin. (FYI learn to decipher TR0138 PCB API Reference.PDF that comes with Altium)

Sub ViaCreation
Dim Board
Dim Via
Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then Exit Sub
PCBServer.PreProcess
For I = 1 to 10
' Create a Via object
Via = PCBServer.PCBObjectFactory(eViaObject, eNoDimension, eCreate_Default)
Via.X = MilsToCoord (I * 50) + Board.XOrigin
Via.Y = MilsToCoord(I * 50) + Board.YOrigin
Via.Size = MilsToCoord(35)
Via.HoleSize = MilsToCoord(15)
Via.LowLayer = eTopLayer
Via.HighLayer = eBottomLayer

' Put this via in the Board object
Board.AddPCBObject(Via)
Call PCBServer.SendMessageToRobots(Board.I_ObjectAddress, c_Broadcast,_ PCBM_BoardRegisteration, Via.I_ObjectAddress)

Next

PCBServer.PostProcess
ResetParameters
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

End Sub

These just makes the screen do a refresh
Call AddStringParameter("Action", "Redraw")
RunProcess("PCB:Zoom")

"Undo Stuff"
PreProcess and PostProcess and the Call PCBServer.SendMessageToRobots(Board.I_ObjectAddress, c_Broadcast, PCBM_BoardRegisteration, Via.I_ObjectAddress)
allow the "Undo" to work with what was just placed on the board, otherwise is may not know that they were added.

http://www.tdpcb.com/

Is this A PCB file?

2011-04-14T21:21:00.001-07:00

Most of the scripts will be for the PCB editor, so I need to check and make sure when I run a script it's actully being run in a PCB file. Access the PCBServer to get things started.

Sub IsthisaPCBFile

Set Board = PCBServer.GetCurrentPCBBoard
If Board is Nothing Then
ShowMessage ("This is not a PCB file!")
Else
ShowMessage ("This is a PCB file!")
End I

End Sub

If a pcb file isn't active in Altium then

Else if a PCB file is active

http://www.tdpcb.com/

Alitum Designer Script Notes Visual Basic (VB)

2011-04-14T21:15:00.000-07:00

Just some running notes as I learn to write VB scripts for Altium.
Starting with the very basics.
In Altium Designer choose File, New, Script Files, VB Script Unit Paste this:

Sub ShowMessageBox

ShowMessage ("Hello! It's " & Time )

End Sub

Run the Script (DXP, Run Script, Choose ShowMessageBox) and you get

http://www.tdpcb.com/