Create a SelectionSet filtered by coordinates and copy it in a different drawing

[Anonymous]

Hi,

My name is Álvaro and I have been working in an issue the last week that i cannot manage to succed in.

I want to write a script in VBA in autocad that creates a selection set filtered by coordinates. After, everything that is within this coordinates should be inserted in a different drawing and save it. 

I was able to manage to make it work to an extent, but i had several setbacks that i cannot strike:

- When i zoom all the window, it doesnt select absolutely anything.

- Depending the zoom in the moment of running the macro, it will select a different number of objects

Due to this fact, i decided to write a different one using "SelectionAll" instead of "SelectionByPolygon". Then the program iterates the selection and if the object is within those coordinates, it will be stored; finally, all the stored data is inserted in a different drawing. But in the same way, this macro doesnt work at all (even the macro doesnt run) and i dont know very well why. 

So that, i will post here both macros that i have written as well as an example drawing. I will very grateful any kind of help. I used to work with VBA creating some macros that insert drawings, blocks, attributes and so on from Excel, but this is the first time i work with VBA in Autocad, therefore im still i little bit lost. Therefore, don´t get mad if you see extremely big mistakes in my Scripts, please!

This macro is the first one, using selectionBypolygon:

Sub prueba()
Dim ssobject As AcadEntity
Dim sset As AcadSelectionSet
Dim sset1 As AcadSelectionSet
Set sset = ThisDrawing.SelectionSets.Add("SS100")
Dim NewDoc As AcadDocument
Dim DOC1MSpace As AcadModelSpace
Dim retObjects As Variant

Dim mode As Integer
Dim pointsArray(0 To 11) As Double
Dim pointI(0 To 2) As Double
Dim pointF(0 To 2) As Double
'ThisDrawing.Application.ZoomAll
mode = acSelectionSetFence
pointsArray(0) = 25000: pointsArray(1) = 400: pointsArray(2) = 0
pointsArray(3) = -400: pointsArray(4) = 400: pointsArray(5) = 0
pointsArray(6) = -400: pointsArray(7) = -400: pointsArray(8) = 0
pointsArray(9) = 25000: pointsArray(10) = -400: pointsArray(11) = 0
sset.SelectByPolygon mode, pointsArray
Set Doc = ThisDrawing.Application.ActiveDocument
If sset.Count > 0 Then

ThisDrawing.CopyObjects ssArray(sset)
Set NewDoc = Application.Documents.Add
Set DOC1MSpace = NewDoc.ModelSpace

retObjects = Doc.CopyObjects(ssArray(sset), DOC1MSpace)
End If

sset.Delete
End Sub
Function ssArray(sset As AcadSelectionSet)
Dim retVal() As AcadEntity
Dim i As Long
ReDim retVal(0 To sset.Count - 1)

For i = 0 To sset.Count - 1
Set retVal(i) = sset.Item(i)
Next
ssArray = retVal

End Function

This macro is will use selectionAll:

Sub prueba2()
Dim ssobject As AcadEntity
Dim sset As AcadSelectionSet
Dim sset1 As AcadSelectionSet
Dim gpCode(0 To 1) As Integer
Dim dataValue(0 To 1) As Variant
Set sset = ThisDrawing.SelectionSets.Add("SS63")

sset.Select acSelectionSetAll
If sset.Count > 0 Then

Call ssArray(sset)
End If
sset.Delete

End Sub
Sub ssArray(sset As AcadSelectionSet)
Dim retObjects As Variant
Dim enType As String
Dim entObj As AcadObject
Dim NewDoc As AcadDocument
Dim DOC1MSpace As AcadModelSpace
Dim retVal() As AcadEntity
Dim retVal1() As AcadEntity
Dim i As Long
Dim pointsArray(0 To 11) As Double
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim vectorpos As Variant
Dim vectorpos1 As Variant
'ReDim retVal(0 To sset.Count - 1)
ReDim retVal(0 To 34000)
ReDim vectorpos(0 To 34000)
pointsArray(0) = 25000: pointsArray(1) = 400: pointsArray(2) = 0
pointsArray(3) = -400: pointsArray(4) = 400: pointsArray(5) = 0
pointsArray(6) = -400: pointsArray(7) = -400: pointsArray(8) = 0
pointsArray(9) = 25000: pointsArray(10) = -400: pointsArray(11) = 0
k = 0
For i = 0 To sset.Count - 1

'enType = sset.Item(i).ObjectName
'If enType = "AcDbText" Then
'Exit For
'End If

sset.Item(i).GetBoundingBox MinPoint, MaxPoint

If MinPoint(0) > pointsArray(3) And MinPoint(0) < pointsArray(0) Then
If MinPoint(1) > pointsArray(7) And MinPoint(1) < pointsArray(4) Then

Set retVal(k) = sset.Item(i)
'vectorpos(k) = k
k = k + 1

End If
End If

Next i

Set Doc = ThisDrawing.Application.ActiveDocument
ThisDrawing.CopyObjects retVal
Set NewDoc = Application.Documents.Add
Set DOC1MSpace = NewDoc.ModelSpace

retObjects = Doc.CopyObjects(retVal, DOC1MSpace)
End Sub

If you open the drawing, you will see two rows of circles. The idea is to insert each  row  in a different document (all the objects, texts, blocks, whatever is in this row). Btw, since i didnt specified the coordinates, it is enough to insert just one row. That would solve my problem and i could keep on working!

Thank you so much

[Anonymous · Accepted solution]

you just need two little modifications to your first code:

- uncomment 'ThisDrawing.Application.ZoomAll code line, otherwise SelectByPolygon() method will act on elements in the current view only (and, BTW, you only need ZoomAll )

- remove ThisDrawing.CopyObjects ssArray(sset) code line, which is just making a copy of selectionset elements (if any) in the same drawing they belong to

furthermore you could consider to refactor your code and:

- give more meaningful names to your variables

- declare variables you actually need to use

- demand any specific task to a function and have your code more clear and maintainable 

like follows:

Option Explicit

Sub prueba2()
    Dim sourceDoc As AcadDocument
    Set sourceDoc = ActiveDocument
    
    Dim pointsArray(0 To 11) As Double
    pointsArray(0) = 25000: pointsArray(1) = 400: pointsArray(2) = 0
    pointsArray(3) = -400: pointsArray(4) = 400: pointsArray(5) = 0
    pointsArray(6) = -400: pointsArray(7) = -400: pointsArray(8) = 0
    pointsArray(9) = 25000: pointsArray(10) = -400: pointsArray(11) = 0
    
    Dim sset As AcadSelectionSet
    Dim mode As Integer
    Set sset = GetSelectionSet(sourceDoc, "SS100")
    mode = acSelectionSetFence
    ZoomAll '<--| zoom All before selecting by fence
    sset.SelectByPolygon mode, pointsArray

    If sset.Count > 0 Then
        With Application.Documents.Add
            sourceDoc.CopyObjects ssArray(sset), .ModelSpace
            ZoomExtents
        End With
    End If
    sset.Delete
End Sub

Function GetSelectionSet(acDoc As AcadDocument, ssetName As String) As AcadSelectionSet
    On Error Resume Next
    Set GetSelectionSet = acDoc.SelectionSets.Item(ssetName)
    If GetSelectionSet Is Nothing Then
        Set GetSelectionSet = acDoc.SelectionSets.Add(ssetName)
    Else
        GetSelectionSet.Clear
    End If
End Function

Function ssArray(sset As AcadSelectionSet)
    Dim i As Long
    ReDim retVal(0 To sset.Count - 1) As AcadEntity
    For i = 0 To sset.Count - 1
        Set retVal(i) = sset.Item(i)
    Next
    ssArray = retVal
End Function

[Anonymous]

Thank you so much for the help as well as the tips! I will test it tomorrow and i will let you know how it was!

Kind regards

Álvaro

[Anonymous]

Good morning,

I tested it, and i realised i should have used "acSelectionSetCrossing". Using that mode the program adds to the selection the objects following my requirements. BTW it was due to the fact that im not highly knowledgeable in this topic yet, and I didnt know very well the functionality of the different selection modes.

But definetely, your post was totally helpful.

Thanks a lot again,

Álvaro