VB+类模块CLS+SelectionSets的应用

兰州人

Dim xlsMdb As New XlsMdbTxtData
Dim CadEnt As New AcadEntity

'主程序
Private Sub Form_Load()
  Dim ojbLine As AcadLine
  Dim pp(0 To 2) As Double, ppp(0 To 2) As Double
  Dim xlSheet1 As Worksheet
  Set xlSheet1 = xlsMdb.ReturnxlSheet("Sheet1")
  Dim objText As AcadText, objTextSelectSet As AcadSelectionSet
  Dim fTypa As Variant, fData As Variant
  fType = Array("0"): fData = Array("Text")
  Set objTextSelectSet = CadEnt.ReturnAllSelectSet(fType, fData)
  Debug.Print objTextSelectSet.Count
  For ii = 0 To objTextSelectSet.Count - 1
    Set objText = objTextSelectSet.Item(ii)
    xlSheet1.Cells(ii + 1, 1) = objText.TextString
  Next ii
 
End Sub

'类模块

Function ReturnAllSelectSet(fTypeArray As Variant, fDataArray As Variant) As AcadSelectionSet
  Dim appAutoCAD As AutoCAD.AcadApplication
  On Error Resume Next
  Set appAutoCad = GetObject(, "AutoCAD.Application")
  If Err Then
    Err.Clear
    Set appAutoCad = CreateObject("AutoCAD.Application")
   
  End If
  appAutoCad.Visible = True
  Dim AcadDoc As AcadDocument
  Set AcadDoc = appAutoCad.ActiveDocument

''
    Dim fType, fData
    ReDim fType(0 To UBound(fTypeArray) + 2) As Integer
    ReDim fData(0 To UBound(fDataArray) + 2) As Variant
    fType(0) = -4
    For ii = 0 To UBound(fTypeArray)
      fType(ii + 1) = fTypeArray(ii)
    Next ii
    fType(UBound(fType)) = -4
    ''
    fData(0) = "<Or"
    For ii = 0 To UBound(fDataArray)
      fData(ii + 1) = fDataArray(ii)
    Next ii
    fData(UBound(fData)) = "Or>"
    ''
    '选择过滤出图形中所有的标注对象
''
  With AcadDoc
    .SelectionSets("mccad").Delete
    Set Sset = .SelectionSets.Add("mccad")
    '建立过滤器
    '选择过滤出图形中所有的标注对象
    Sset.Select 5, , , fType, fData
    Set ReturnAllSelectSet = Sset
  End With
 
End Function

兰州人

Sub LS()
  Dim rr As AcadSelectionSet
  Dim objText As AcadText
  fType = Array("0"): fData = Array("Text")
  Set rr = ReturnAllSelectSet(fType, fData)
  For ii = 0 To rr.Count - 1
    Select Case rr.Item(ii).ObjectName
      Case "AcDbText"
        Set objText = rr.Item(ii)
        With objText
          Debug.Print .TextString
        End With
    End Select
  Next ii
End Sub
Function ReturnAllSelectSet(fTypeArray As Variant, fDataArray As Variant) As AcadSelectionSet
  Dim appAutoCad As AutoCAD.AcadApplication
  On Error Resume Next
  Set appAutoCad = GetObject(, "AutoCAD.Application")
  If Err Then
    Err.Clear
    Set appAutoCad = CreateObject("AutoCAD.Application")
   
  End If
  appAutoCad.Visible = True
  Dim AcadDoc As AcadDocument
  Set AcadDoc = appAutoCad.ActiveDocument

''
    Dim fType, fData
    ReDim fType(0 To UBound(fTypeArray) + 2) As Integer
    ReDim fData(0 To UBound(fDataArray) + 2) As Variant
    fType(0) = -4
    For ii = 0 To UBound(fTypeArray)
      fType(ii + 1) = fTypeArray(ii)
    Next ii
    fType(UBound(fType)) = -4
    ''
    fData(0) = "<Or"
    For ii = 0 To UBound(fDataArray)
      fData(ii + 1) = fDataArray(ii)
    Next ii
    fData(UBound(fData)) = "Or>"
    ''
    '选择过滤出图形中所有的标注对象
''
  With AcadDoc
    .SelectionSets("mccad").Delete
    Set Sset = .SelectionSets.Add("mccad")
    '建立过滤器
    '选择过滤出图形中所有的标注对象
    Sset.Select 5, , , fType, fData
    Set ReturnAllSelectSet = Sset
  End With
 
End Function