这是我的一小段程序，有漏洞运算不准确，请大家改改[讨论]
大家给看看，我这段程序呢目的是要把字识别出来，然后分别按y,x排序，但是举个例子，比如我识别出268个字也就是268个坐标，但是在排序的时候，按x排会出现568个坐标，按y排会有789个坐标。请大家研究一下，小弟刚上手没多久，多多帮忙我上传了一个表 我用下面的程序运算 206个字然后排序 就有3284958 个坐标拉！
赫赫，我找不出问题呀，大家看看
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
re
大家帮忙拉虽然我想帮你
但实在是看不大明白 能不能写的简单清楚些re
好的，我写的详细些还是使用多维数组来的方便
声明一个Dim a(1 To 10000,0 to 2) As Double用于保存所有文本的插入点坐标,之后就省去了每次都要查找模型空间中的文字这一段操作,进行排序时可以复制一份进行操作.关于记录重复,应该是在程序当中输出时重复了检查一下.
因为其中很多文字x或y坐标是相同的
重复的原因应该如上。efan斑竹的说的很有道理。建议定义二维数组或者建立选择集－－复制选择集－－对其中文字对象直接排序－－一次性输出。
如果对象不是太多，对选择集中对象排序不会要很多时间，而程序会清楚很多，省去反复的循环。
re
这几天没上来看，真是可惜了，我试着改改，若是我改不了，还请大家帮忙。版主：这个重复检查了一下，到底详细上怎么说
re
Option ExplicitPrivate 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, 0 To 2) As Double
Dim b(1 To 10000, 0 To 2) 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, 0) = point1(0)
a(i, 1) = point1(1)
b(i, 0) = point1(0)
b(i, 1) = 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 Variant
Dim n As Integer
n = totalczx
For i = 1 To n - 1 '排序
im = i
For j = i + 1 To n
If a(j, 0) < a(im, 0) Then im = j
Next j
t = a(i, 0)
a(i, 0) = a(im, 0)
a(im, 0) = t
Next i
For i = 1 To czx
Next i
czx = 0
Open "e:\字的排序按x坐标.txt" For Output As #3
For i = 1 To totalczx
czx = czx + 1
Write #3, czx, a(i, 0), a(i, 1), a(i, 2)
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, 1) < b(im, 1) Then im = j
Next j
t = b(i, 1)
b(i, 1) = b(im, 1)
b(im, 1) = t
Next i
For i = 1 To czx
Next i
czx = 0
Open "e:\字的排序按y坐标排序.txt" For Output As #4
For i = 1 To totalczx
czx = czx + 1
Write #4, czx, b(i, 0), b(i, 1), b(i, 2)
Next i
Close #4
End Sub
re1
上述的程序，运算结果1372个点，应该对了，呵呵，谢谢版主，z兄
页:
[1]