社区 › Auto Lisp › 获取文本的坐标

habakay 发表于 2022-7-6 22:09:55

获取文本的坐标

你好
可以获取分配给集合的任何文本对象的坐标吗？
首先，我将selectionset中的一些文本添加到collection中。然后我想根据它们的坐标X和Y对这些集合成员进行排序。但是我无法得到集合成员的坐标。这是我的收藏：
 
 
对于oSset中的每个oObj
如果oObj的类型为AcadText，则
 
Set oText=oObj
 
如果InStr（1，oText.TextString，“Km=”）>0，则
 
collection_km。添加文字
 
如果结束
如果结束
下一个oObj
 
 
我尝试了这个，但它给出了一个错误
collection_km。项目（i）。插入点（0）
谢谢你的建议

SEANT 发表于 2022-7-6 22:20:43

也许可以尝试：
 
 
设置oText=collection\u km。项目（i）
双精度dblX
dblX=文字。插入点（0）

fixo 发表于 2022-7-6 22:29:59

从我的代码中尝试，略作编辑

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

habakay 发表于 2022-7-6 22:30:04

谢谢你的关注。我根据你的代码编辑代码，但不能使用成员的坐标。
当我试图在“If…Else If”循环中比较它们时，它再次给出了一个错误。
你能举个例子解释一下吗？
例如：
我的集合中有三个textArr数组。
这些textArr数组中的每一个都有三个这样的属性（textArr（0）=oText。插入点（0），textArr（1）=oText。插入点（1），textArr（2）=oText。文本字符串）
是否可以根据这些textarr在循环中的插入点对集合中的这些textarr进行比较和重新排序？
谢谢

fixo 发表于 2022-7-6 22:41:17

habakay，我认为使用2个十进制数组就足够了
不是收藏，再一次，这是我的老歌，对不起，
没时间解释好

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

habakay 发表于 2022-7-6 22:44:30

谢谢你的关注。

habakay 发表于 2022-7-6 22:53:22

 
谢谢你的代码。我使用你的代码并修复我的代码。但我仍然有错误。数组出现“类型不匹配”错误。
你能看一下吗？
这是我的密码
 
 


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


谢谢

RICVBA 发表于 2022-7-6 23:03:20

在这里，你可以找到我的建议，以及一些评论（它们前面都有“
 
选项显式约束xlFileName为String=“C:\Users\halil.abakay\Desktop\AutoCAD.xlsx”

habakay 发表于 2022-7-6 23:08:28

 
 
 
我非常感激。它工作完美。

RICVBA 发表于 2022-7-6 23:16:30

 
好的
干得好！

查看完整版本: 获取文本的坐标