[编程交流] 获取文本的坐标

Public Sub TestCollectTextPoints()
Dim ent As AcadEntity
Dim objSSet As AcadSelectionSet
Dim setObj As AcadSelectionSet
Dim oText As AcadText
Dim oMText As AcadMText
Dim intFilterType(0 To 0) As Integer
Dim varFilterData(0 To 0) As Variant
Dim dxfCode, dxfValue
intFilterType(0) = 0: varFilterData(0) = "TEXT,MTEXT" 'to select texts and mtexts
  ' Creates an empty selection set.
      Dim setColl As AcadSelectionSets
    With ThisDrawing
         Set setColl = .SelectionSets
         For Each setObj In setColl
              If setObj.Name = "mySelSet" Then
                   .SelectionSets.item("mySelSet").Delete
                   Exit For
              End If
         Next
         Set objSSet = .SelectionSets.Add("mySelSet")
    End With
objSSet.SelectOnScreen intFilterType, varFilterData
If objSSet.Count = 0 Then
Exit Sub
End If
Dim txtColl As New Collection
Dim n As Long
n = 0
Dim textArr(0 To 3) As Variant
For Each ent In objSSet
If TypeOf ent Is AcadText Then
Set oText = ent
 'store text record in array
textArr(0) = oText.handle
textArr(1) = oText.InsertionPoint(0)
textArr(2) = oText.InsertionPoint(1)
textArr(3) = oText.TextString
txtColl.Add textArr
End If
If TypeOf ent Is AcadMText Then
Set oMText = ent
' 'store mtextrecord in array
textArr(0) = oMText.handle
textArr(1) = oMText.InsertionPoint(0)
textArr(2) = oMText.InsertionPoint(1)
textArr(3) = oMText.TextString
txtColl.Add textArr
End If
Next ent
' write collection to comma delimited file,
' You can use .csv extension instead of .txt
Call ahha("C:\Test\MyTextCollection.txt", txtColl)
'release collection at the end
Set txtColl = Nothing
End Sub

Option Explicit
Sub TestTextSort()
    Dim ss As AcadSelectionSet
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim ent As AcadEntity
    Dim hndl As String
    Dim xcoord As Double
    Dim ycoord As Double
    Dim i As Integer
    Dim j As Integer
    Dim tmp As Variant
    Dim otext As AcadText
    Dim txtstring As String
    ftype(0) = 0:
    fdata(0) = "TEXT":
         With ThisDrawing.SelectionSets
              While .Count > 0
                   .Item(0).Delete
              Wend
         End With
    With ThisDrawing.SelectionSets
         Set ss = .Add("SortText")
         End With
 ss.SelectOnScreen ftype, fdata
 If ss.Count = 0 Then
 MsgBox "Nothing selected"
 Exit Sub
 Else
 ' collect text handles and Y-coordinates of block for sorting them
 ' below by Y-coordinate from top to bottom:
 ReDim txtdata(0 To ss.Count - 1, 0 To 3)
 i = 0
 For Each ent In ss
 Set otext = ent
 hndl = otext.Handle
 xcoord = otext.InsertionPoint(0)
 ycoord = otext.InsertionPoint(1)
 txtstring = otext.TextString
 txtdata(i, 0) = ycoord: txtdata(i, 1) = ycoord: txtdata(i, 2) = txtstring: txtdata(i, 3) = hndl
 i = i + 1
 Next ent
 'sort blocks by X
  txtdata = CoolSort(txtdata, 1) ' by Y would be txtdata = CoolSort(txtdata, 2)
  ' iterate through array and return text reference object
  ' check if sorting algorithm is right
  For i = 0 To UBound(txtdata, 1)
  Set otext = ThisDrawing.HandleToObject(txtdata(i, 3))
  Debug.Print otext.TextString
  Next i
End If
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. () 2006 * all rights removed '
' SourceArr - two dimensional array '
' iPos - "column" number (starting from 1) '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function CoolSort(SourceArr As Variant, iPos As Integer) As Variant
Dim Check As Boolean
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Dim iCount As Integer
Dim jCount As Integer
Dim nCount As Integer
iPos = iPos - 1
Check = False
Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
If SourceArr(iCount, iPos) < SourceArr(iCount + 1, iPos) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop
CoolSort = SourceArr
End Function

Option Explicit
Const xlFileName As String = "C:\Users\halil.abakay\Desktop\AutoCAD.xlsx" '<--change existing file name here
Public Sub Text_to_Excel()
Dim SS As AcadSelectionSet
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim obj As AcadObject
Dim otext As AcadText
Dim txtdata_km
Dim txtdata_srbst
Dim txtdata_dolgu
Dim txtdata_yarma
Dim counter1 As Long
Dim counter2 As Long
Dim counter3 As Long
Dim counter4 As Long
Dim counterveri As Integer
Dim k As Integer
Dim xcoord As Double
Dim ycoord As Double
Dim txtstring As String
Dim xlApp As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim lngRow As Long, lngCol As Long
On Error Resume Next
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   Set xlApp = GetObject(, "Excel.Application")
   
   If Err <> 0 Then
       Err.Clear
       Set xlApp = CreateObject("Excel.Application")
   If Err <> 0 Then
       MsgBox "Impossible to run Excel.", vbExclamation
       End
   End If
   End If
   xlApp.Visible = True
   
   Set xlBook = xlApp.Workbooks.Open(xlFileName)
   
   Set xlSheet = xlBook.Sheets(1)
   
   xlApp.ScreenUpdating = True
   If xlSheet.Range("A1") = "" Then
       lngRow = 1: lngCol = 1
   Else
       lngRow = xlSheet.Range("a65536").End(3).Offset(1, 0).Row: lngCol = 1
   End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   ftype(0) = 0:
   fdata(0) = "TEXT":
   With ThisDrawing.SelectionSets
       While .Count > 0
           .Item(0).Delete
       Wend
   End With
   
   With ThisDrawing.SelectionSets
       Set SS = .Add("Textkubaj")
   End With
   SS.SelectOnScreen ftype, fdata
   
   
   If SS.Count = 0 Then
       MsgBox "Nothing selected"
       Exit Sub
   Else
       counter1 = 0
       counter2 = 0
       counter3 = 0
       counter4 = 0
       counterveri = 0
       For Each obj In SS
               
               Set otext = obj
               
               If InStr(1, otext.TextString, "Km =") > 0 Then
                   counter1 = counter1 + 1
                   ReDim Preserve txtdata_km(0 To 2, counter1 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_km(0, counter1 - 1) = xcoord: txtdata_km(1, counter1 - 1) = ycoord: txtdata_km(2, counter1 - 1) = txtstring
                   counterveri = counterveri + 1
                   
               ElseIf InStr(1, otext.TextString, "Serbest Kazı=") > 0 Then
                   counter2 = counter2 + 1
                   ReDim Preserve txtdata_srbst(0 To 2, 0 To counter2 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_srbst(0, counter2 - 1) = xcoord: txtdata_srbst(1, counter2 - 1) = ycoord: txtdata_srbst(2, counter2 - 1) = txtstring
                   counterveri = counterveri + 1
               
               ElseIf InStr(1, otext.TextString, "Dolgu =") > 0 Then
                   counter3 = counter3 + 1
                   ReDim Preserve txtdata_dolgu(0 To 2, 0 To counter3 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_dolgu(0, counter3 - 1) = xcoord: txtdata_dolgu(1, counter3 - 1) = ycoord: txtdata_dolgu(2, counter3 - 1) = txtstring
                   counterveri = counterveri + 1
               
               ElseIf InStr(1, otext.TextString, "Yarma =") > 0 Then
                   counter4 = counter4 + 1
                   ReDim Preserve txtdata_yarma(0 To 2, 0 To counter4 - 1)
                   xcoord = otext.InsertionPoint(0)
                   ycoord = otext.InsertionPoint(1)
                   txtstring = otext.TextString
                   txtdata_yarma(0, counter4 - 1) = xcoord: txtdata_yarma(1, counter4 - 1) = ycoord: txtdata_yarma(2, counter4 - 1) = txtstring
                   counterveri = counterveri + 1
               
               Else: GoTo devam
               End If
               
devam:
       Next obj
   
   End If
               
               
For k = 0 To counter1 - 1
           MsgBox txtdata_km(k, 0)
           xlSheet.Cells(lngRow, lngCol + 1).Value = txtdata_km(k, 0)
           xlSheet.Cells(lngRow, lngCol + 2).Value = txtdata_km(k, 1)
           xlSheet.Cells(lngRow, lngCol).Value = Replace(Replace(txtdata_km(k, 2).TextString, "Km =", ""), ".", ",")
           lngRow = lngRow + 1
Next k
   
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
xlSheet.Columns.HorizontalAlignment = xlHAlignLeft
xlSheet.Columns.AutoFit
xlApp.ScreenUpdating = True
xlBook.Save
xlBook.Close
xlApp.Quit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
counter1 = Empty
counter2 = Empty
counter3 = Empty
counter4 = Empty
counterveri = Empty
k = Empty
Set txtdata_km = Nothing
Set txtdata_srbst = Nothing
Set txtdata_dolgu = Nothing
Set txtdata_yarma = Nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
MsgBox "Done"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Err_Control:
If Err.Number <> 0 Then
   MsgBox Err.Description
End If
End Sub