AcadSelectionSet для ручной модификации (Страница 1 из 2)

vSS.Highlight True

vSS.Highlight True
ThisDrawing.SendCommand "(sssetfirst (ssget ""_P"") ) "

(ssget)

(sssetfirst nil (ssget))

Option Explicit
'Выделение объектов по типу и слою
'by Алексей Громов
Sub SelByName()
Dim Etalon As AcadEntity
Dim PPoint As Variant
Dim ss As AcadSelectionSet
Dim SSet As AcadSelectionSet
Dim EtName As String
Dim EtLay As String
Dim FType(3) As Integer
Dim FData(3) As Variant
Dim SETS As AcadSelectionSets
Dim ASpace As AcActiveSpace
On Error Resume Next
Set SETS = ThisDrawing.SelectionSets
Call SSCheck("SS01")
ThisDrawing.Utility.GetEntity Etalon, PPoint, "Выбрать по:"
If Etalon Is Nothing Then
    Exit Sub
End If
Select Case Etalon.EntityName
    Case "AcDb3dPolyline"
        EtName = "polyline"
    Case "AcDb2dPolyline"
        EtName = "polyline"
    Case "AcDbPolyline"
        EtName = "lwpolyline"
    Case "AcDbBlockReference"
        EtName = "insert"
    Case "AcDbAlignedDimension"
        EtName = "dimension"
    Case "AcDbRotatedDimension"
        EtName = "dimension"
    Case Else
        EtName = Replace(Etalon.EntityName, "AcDb", "")
End Select
EtLay = Etalon.Layer
ASpace = (Not ThisDrawing.ActiveSpace) + 2
FType(0) = 0
FData(0) = EtName
FType(1) = 8
FData(1) = EtLay
FType(2) = 67
FData(2) = ASpace
FType(3) = 100
FData(3) = Etalon.ObjectName
Set SSet = SETS("SS01")
SSet.Select acSelectionSetAll, , , FType, FData
ThisDrawing.SendCommand "_pselect" & vbCr & "p" & vbCr & vbCr
End Sub

Function SSCheck(SSNM As String)
    Dim SelSet As AcadSelectionSet
    Dim CheckFlag As Boolean
    CheckFlag = False
        For Each SelSet In ThisDrawing.SelectionSets
            If SelSet.Name = SSNM Then
                CheckFlag = True
            End If
        Next SelSet
        If CheckFlag = False Then
            ThisDrawing.SelectionSets.Add (SSNM)
        Else
            ThisDrawing.SelectionSets(SSNM).Clear
        End If
End Function

Select Case Etalon.EntityName
.
.
.
End Select

For Each SelSet In ThisDrawing.SelectionSets
    If SelSet.Name = "SS01" Then
        SelSet.Delete
        Exit For
    End If
Next SelSet

Sub SelectToGRIP()
Dim AcadObj As AcadObject
Dim ArrayObj(0) As AcadObject
Dim SelGroupObjs As AcadGroup
   With ActiveDocument
      For Each SelGroupObjs In .Groups
         If UCase(SelGroupObjs.Name) = "$EXPSELGROUPOBJS_0A1H2F3B" Then SelGroupObjs.Delete: Exit For
      Next SelGroupObjs
      Set SelGroupObjs = .Groups.Add("$EXPSELGROUPOBJS_0A1H2F3B")
      For Each AcadObj In .ModelSpace
         Set ArrayObj(0) = AcadObj
         SelGroupObjs.AppendItems ArrayObj
      Next AcadObj
      Set AcadObj = Nothing
      .SendCommand _
        "(sssetfirst nil)" & _
        "(setq expsel(ssget))" & vbCr & _
        "_Group" & vbCr & "$EXPSELGROUPOBJS_0A1H2F3B" & vbCr & vbCr & _
        "(sssetfirst nil expsel)" & _
        "(princ)" & vbCr
   End With
   SelGroupObjs.Delete
   Set SelGroupObjs = Nothing
End Sub