版主帮忙，关于在cad中找出字，并且找出字的起点，端点的坐标[求助]
Dim textobj As AcadEntityDim point1 As Variant
Dim point2 As Variant
For Each textobj In ThisDrawing.ModelSpace '找字
If textobj.ObjectName = "AcaDtext" Then
point1 = textobj.StartPoint
point2 = textobj.EndPoint
版主，我是个新手，很多东西都不懂，上面的这段，我的目的是想找出说有的字，然后比所有的字的插入点坐标找到，但是对于插入点，以及字的属性，搞不懂，因此找不到，还请版主帮忙给指点一下。
RE
本帖最后由 作者 于 2003-6-12 15:08:09 编辑首先建立一个AcadTextSet的选择集：
Dim AcadTextSet As AcadSelectionSet
Dim TextObj As AcadText
Dim Point1,Point2 As Variant
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Set AcadTextSet= ThisDrawing.SelectionSets.Add("ACADTEXT
")
FilterType(0)=0：FilterData(0)="TEXT"
AcadTextSet.Select acSelectionSetAll, , , FilterType, FilterData
For Each TextObj In AcadTextSet
'Point1 = TextObj.StartPoint
'Point2 = TextObj.EndPoint
Point1= TextObj.InsertionPoint
'...
Next
re
楼上的，你的程序我有点看不懂，并且我运行的时候，怎么有错误，还请指教。123
楼主说的是文字的坐标？单行文字有insertposition属性（看看帮助文件核对一下），但似乎不好直接使用，因为还不知道文字对齐方式。
用getboundingbox 比较方便，具体的在help文件里很详细。
关于对象属性，仍然推荐帮助文件，呵呵。那里是最及时最详细的老师。
Z兄说得对，帮助文件是最好的老师
另外，关于文字的坐标及其他属性的实际应用，在本站“源码分析”区有篇文章可以参考：http://www.mjtd.com/bbs/dispbbs.asp?BoardID=16&RootID=21361&ID=21420&skin=1
你们好厉害
各位给我写的那一段，指点一下吧，应该怎么改，呵呵，我要学得太多了RE
Point1 = TextObj.StartPointPoint2 = TextObj.EndPoint
改为：TEXT无StartPoint 和EndPoint属性
TextObj.InsertionPoint
加一个getboundbox 的
楼上的给了InsertionPoint的说法，再贴一个getboundbox 的，基本就是文字起点端点的意思。大致如下：Sub Example_GetBoundingBox()
Dim minExt As Variant
Dim maxExt As Variant
' Return the bounding box for the text and return the minimum
' and maximum extents of the box in the minExt and maxExt variables.
TextObj.GetBoundingBox minExt, maxExt
' Print the min and max extents
MsgBox "The extents of the bounding box for the text are:" & vbCrLf _
& "Min Extent: " & minExt(0) & "," & minExt(1) & "," & minExt(2) _
& vbCrLf & "Max Extent: " & maxExt(0) & "," & maxExt(1) & "," & maxExt(2), vbInformation, "GetBoundingBox Example"
End Sub
re
谢谢大家，识别字搞定了，我想得太多了，我最后选了insertposition属性因为我考虑多了，我要把字排序，用不到端点坐标，这样的话，就简单了。
Dim textobj As AcadEntity
Dim point1 As Variant
Dim point2 As Variant
For Each textobj In ThisDrawing.ModelSpace '找字
If textobj.ObjectName = "AcDbText" Then
point1 = textobj.insertposition
。。。。。。。
End If
Next
这样就行了
还有个问题，我运行程序有漏洞，请大家看看
大家给看看，我这段程序呢目的是要把字识别出来，然后分别按y,x排序，但是举个例子，比如我识别出268个字也就是268个坐标，但是在排序的时候，按x排会出现568个坐标，按y排会有789个坐标。请大家研究一下，小弟刚上手没多久，多多帮忙Option Explicit
Private Sub CommandButton1_Click()
Dim totalczx As Integer
Dim czx, spx As Integer
Dim textobj As AcadEntity
Dim point1 As Variant
Dim point2 As Variant
Dim a(1 To 10000) As Double
Dim b(1 To 10000) As Double
Dim i, j As Integer
i = 1
j = 1
czx = 0
Open "e:\1.txt" For Output As #1 '
For Each textobj In ThisDrawing.ModelSpace '找字
If textobj.ObjectName = "AcDbText" Then
point1 = textobj.InsertionPoint
a(i) = point1(0)
b(j) = point1(1)
i = i + 1
j = j + 1
czx = czx + 1
Write #1, czx, point1(0), point1(1), point1(2)
End If
Next
totalczx = czx
Close #1
'############################首先按x坐标排序####################################333
Dim im As Integer
Dim t As Double
Dim n As Integer
n = totalczx
For i = 1 To n - 1 '排序
im = i
For j = i + 1 To n
If a(j) < a(im) Then im = j
Next j
t = a(i)
a(i) = a(im)
a(im) = t
Next i
For i = 1 To czx
Next i
Close #2
czx = 0
Open "e:\字的排序按x坐标.txt" For Output As #3
For i = 1 To totalczx
For Each textobj In ThisDrawing.ModelSpace
If textobj.ObjectName = "AcDbText" Then
point1 = textobj.InsertionPoint
If a(i) = point1(0) Then
czx = czx + 1
Write #3, czx, point1(0), point1(1), point1(2)
End If
End If
Next
Next i
Close #3
'######################然后按y坐标排序########################333
n = totalczx '假设水平线的数目为100
For i = 1 To n - 1 '排序
im = i
For j = i + 1 To n
If b(j) < b(im) Then im = j
Next j
t = b(i)
b(i) = b(im)
b(im) = t
Next i
For i = 1 To czx
Next i
Close #6
czx = 0
Open "e:\字的排序按y坐标排序.txt" For Output As #4
For i = 1 To totalczx
For Each textobj In ThisDrawing.ModelSpace
If textobj.ObjectName = "AcDbText" Then
point1 = textobj.InsertionPoint
If b(i) = point1(1) Then
czx = czx + 1
Write #4, czx, point1(0), point1(1), point1(2)
End If
End If
Next
Next i
Close #4
End Sub
页:
[1]
2