Selection Sets in Autocad VBA do not contain methods to Move, Copy, Rotate, Scale, Mirror etc. The programmer has to make a For-Each loop to iterate through the Selection Set and apply the method to each individual entity one at a time. There are quite a few steps between making the selection set, populating it, then looping through its members and actually doing something to them. Breaking down these steps into small re-usable sub-procedures is the way to go.
Other than how to use them, Selection Sets have pretty good documentation not too hard to understand. The first sub-procedure makes a new clean Selection Set in the drawing. If it already exists it deletes it. Its called with a parameter name.
Sub addss(strname As String)
'adds a clean selection set
Dim sset As AcadSelectionSet
On Error Resume Next
Set sset = acadDoc.SelectionSets.Item(strname)
sset.Delete
Set sset = acadDoc.SelectionSets.Add(strname)
If sset Is Nothing Then
MsgBox "unable to add " & strname & " selection set"
End If
End Sub
In a recent program I made two kinds of selection, ALL and Window, so I made two function procedures to handle this task and return an AcadSelectionSet object. These functions call addss above. The way these work are documented and easily found with VBA ACADSelectionSets. Think of this as the second layer of abstraction, a function to make and return a set according to your selection method.
Function sset_all() As AcadSelectionSet
'returns a selection set ALL
addss ("All_Entities")
Set sset_all = acadDoc.SelectionSets.Item("All_Entities")
sset_all.Select acSelectionSetAll
End Function
Function sset_win(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As AcadSelectionSet
'returns a selection set with window selection
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Call initpt(pt1, x1, y1, 0)
Call initpt(pt2, x2, y2, 0)
'items not visible do not select
acadApp.Update
acadApp.ZoomAll
addss ("Win_Entities")
Set sset_win = acadDoc.SelectionSets.Item("Win_Entities")
sset_win.Select acSelectionSetWindow, pt1, pt2
End Function
Sub initpt(ByRef ptn() As Double, val1 As Double, val2 As Double, val3 As Double)
ptn(0) = val1: ptn(1) = val2: ptn(2) = val3
End Sub
initpt is a little helper I made. You don’t need the ByRef keyword, I put it in there to remind that arrays always pass by reference. It would not work otherwise.
Now we have, when properly called, a selection set of our choosing. We want to make sub-procedures for MOVE, COPY, ROTATE, MIRROR and SCALE which accept a selection set as an argument and whatever other basic parameters required, such as a displacement for MOVE. This is the third level of abstraction. We are calling these methods with a selection set previously selected by whatever method.
Erase is the simplest case. it doesnt require a loop.
Sub erase_ss(sset As AcadSelectionSet)
sset.Erase 'erases the autocad entities in the drawing
sset.Delete 'deletes the selection set
Set sset = Nothing
'call by reference will set to nothing in calling program
End Sub
now finally here is the code to MOVE a selection set using a loop to go thru the set for each item. It takes the set itself as argument and the displacement in x and y. You can select items with either of the subs above by window or all or your program with Crossing or Filters. Deleting the selection set at the end of the routine is optional and may not always be desired, say if you wanted to move and rotate.
Sub move_ss(sset As AcadSelectionSet, x1 As Double, y1 As Double)
'x1 y1 is the displacement
Dim objent As AcadEntity
Dim pt0(0 To 2) As Double
Dim pt1(0 To 2) As Double
Call initpt(pt0, 0, 0, 0)
Call initpt(pt1, x1, y1, 0)
If 0 <> sset.Count Then
For Each objent In sset
objent.Move pt0, pt1
Next
End If
sset.Delete 'deletes the selection set
Set sset = Nothing
'call by reference will set to nothing in calling program
End Sub
At this point these sub-procedures still do not change per program requirements. They are basic tools.
Here are mirror and scale (I have not needed COPY yet).
Sub mirror_ss(sset As AcadSelectionSet, pt1() As Double, pt2() As Double)
'deletes old copy, pt1 pt2 are axis
Dim objent As AcadEntity
Dim objent_mirrored As AcadEntity
If 0 <> sset.Count Then
For Each objent In sset
Set objent_mirrored = objent.Mirror(pt1, pt2)
objent.Delete
Next
End If
sset.Delete
Set sset = Nothing
End Sub
Sub scale_ss(sset As AcadSelectionSet, x1 As Double, y1 As Double, sc As Integer)
'x1 y1 is the scale from point, sc is the scale factor
Dim objent As AcadEntity
Dim pt0(0 To 2) As Double
Call initpt(pt0, x1, y1, 0)
If 0 <> sset.Count Then
For Each objent In sset
objent.ScaleEntity pt0, sc
Next
End If
acadApp.Update
acadApp.ZoomAll
sset.Delete 'deletes the selection set
Set sset = Nothing
'call by reference will set to nothing in calling program
End Sub
Now to some extent, we have hidden the loops, we don’t have to duplicate them, and we can call them with simple programs. Here are some upper level calling programs. You will need to write your own according to the method and selection you want to use.
Sub erase_all()
Dim sset As AcadSelectionSet
Set sset = sset_all
Call erase_ss(sset)
End Sub
Sub move_all(x1 As Double, y1 As Double)
Dim sset As AcadSelectionSet
Set sset = sset_all
Call move_ss(sset, x1, y1)
End Sub
Sub scale_w(x1 As Double, y1 As Double, x2 As Double, y2 As Double, sc As Integer)
'scales from pt 0,0
Dim sset As AcadSelectionSet
Set sset = sset_win(x1, y1, x2, y2)
Call scale_ss(sset, 0, 0, sc)
End Sub
Sub mirror_all(pt1() As Double, pt2() As Double)
Dim sset As AcadSelectionSet
Set sset = sset_all
Call mirror_ss(sset, pt1, pt2)
End Sub
those get called rather simply by your top level, where you can see what you are doing without having to dive in to the details.
Call erase_all
Call move_all (0,20)
Call scale_w(-1, -1, 12, 9.5, sc)
Call mirror_all(vt1, vt4)
when you draw with xy data starting at the origin, this is how you move and position the piece onto your drawing assembly or border.
