图元排序问题

vlisp2012 · 发表于 2012-10-7 22:06:07

求助大家帮个忙，我想要像图中的图元排序，怎样编程啊？
首先考虑y坐标，在一定容差范围内，对图元的x坐标排序；
之后再对y坐标排序。

ynhh · 发表于 2012-11-19 08:49:19

zml84 发表于 2012-11-13 19:22
网友 ynhh 在6楼评论所言“容差”问题，请细看equal函数。

大师指点的对，是我自己没看这个函数的说明，你太伟大了。
你这程序真神。但无法选择先对Y方向再对X方向的竖排啊，能不能再优化可选择X或Y优先？

skg123 · 发表于 2021-5-21 15:08:59

6楼 zml84 大神代码强悍。，测试可行，还有有容差判断

修改 (if (equal (cadr e1) (cadr e2) 1e1) 中的 1e1 变量就实现容差

图片上白色上参考线，偏差参考线的圆照样编号，强大

xyp1964 · 发表于 2019-1-29 13:35:26

本帖最后由 xyp1964 于 2019-1-29 13:38 编辑

(defun c:tt (/ lst)
(setq ukw (Ukword 1 "1 2" "1-先上下后左右/2-先左右后上下" ukw)) (princ "\n请选择要排序的实体...")
(if (setq ss (ssget '((0 . "circle"))))
(progn
(setq i 0)
(repeat (sslength ss)
(setq pt (cdr (assoc 10 (entget (ssname ss i))))
lst (cons pt lst)
i (1+ i)
)
)
(setq lst (if (= ukw "1")
(vl-sort lst '(lambda (x y) (if (equal (cadr x) (cadr y) 1e-3) (< (car x) (car y))(> (cadr x) (cadr y)))))
(vl-sort lst '(lambda (x y)(if (equal (car x) (car y) 1e-3)(> (cadr x) (cadr y))(< (car x) (car y))))))
i 0
)
(mapcar '(lambda (x)
(setq i (1+ i) bh (itoa i))
(command "text" "j" "mc" "non" x 25 0 bh)
)
lst
)
)
)
(princ)
)

(defun c:tt (/ lst) 
  (setq ukw (Ukword 1 "1 2" "1-先上下后左右/2-先左右后上下" ukw))   (princ "\n请选择要排序的实体...") 
  (if (setq ss (ssget '((0 . "circle")))) 
    (progn 
      (setq i 0) 
      (repeat (sslength ss) 
        (setq pt  (cdr (assoc 10 (entget (ssname ss i)))) 
              lst (cons pt lst) 
              i          (1+ i) 
        ) 
      ) 
      (setq lst        (if (= ukw "1") 
                  (vl-sort lst '(lambda (x y) (if (equal (cadr x) (cadr y) 1e-3) (< (car x) (car y))(> (cadr x) (cadr y))))) 
                  (vl-sort lst '(lambda (x y)(if (equal (car x) (car y) 1e-3)(> (cadr x) (cadr y))(< (car x) (car y)))))) 
            i        0 
      ) 
      (mapcar '(lambda (x) 
                 (setq i  (1+ i)  bh (itoa i)) 
                 (command "text" "j" "mc" "non" x 25 0 bh) 
               ) 
              lst 
      ) 
    ) 
  ) 
  (princ) 
)

zml84 · 发表于 2012-10-9 13:04:54

本帖最后由 zml84 于 2012-10-9 13:05 编辑

(defun c:tt ()
    (princ "\n请选择要排序的实体...")
    (if	(setq ss (ssget))
	(progn
	    ;; 1、获取点位表
	    (setq lst '()
		  i   0
	    )
	    (repeat (sslength ss)
		(setq en  (ssname ss i)
		      ent (entget en)
		      pt  (cdr (assoc 10 ent))
		      lst (cons pt lst)
		      i	  (1+ i)
		)
	    )
	    ;; 2、排序
	    (setq
		lst (vl-sort
			lst
			(function
			    (lambda (e1 e2)
				(if (equal (cadr e1) (cadr e2) 1e1)
				    (< (car e1) (car e2))
				    (< (cadr e1) (cadr e2))
				)
			    )
			)
		    )
	    )
	    ;; 3、写序号文字
	    (setq i 1)
	    (foreach pt	lst
		(command "_.text" "j" "mc"  "non"pt (getvar "TEXTSIZE") 0 (itoa i))
		(setq i (1+ i))
	    )




	)
    )
    (princ)
)

vlisp2012 · 发表于 2012-10-7 22:06:42

本帖最后由 vlisp2012 于 2012-10-7 22:14 编辑

附上cad文件。
比如对附图中的圆中，写入文字。

xiabin68 · 发表于 2012-10-8 11:48:41

你可以参考我编的圆编号并排序代码

陨落 · 发表于 2012-10-8 13:27:56

参考vl-sort，很方便的

huaxiamengqing · 发表于 2012-10-8 23:37:39

我使用VBA写的，核心代码下面是，如果使用.net写还可以更加简单

'循环将CAD图形内图元以坐标分堆
'华夏梦清 2012年7月11日，江河梦小组
'循环x,y方向探测是否有距离大于Mjg的相邻文字，如果有那么将后面的去掉，然后（不管有没有）两个方向上是否有间隔大于Mjg的
'如果没有跳出循环说明取出了了一张表格，然后继续递归此过程
'**************************************************************************************************************************
Public OutTextDic As New Scripting.Dictionary '储存的公共字典，返回数据，分堆储存
Public ExcelTextdic As New Scripting.Dictionary '创建toexcel公共字典
Public STMi As Long '分出表格的个数
Public Mjg As Double '水平竖直大于多少分隔为一个表格
'直接导入Excel表格
Public Sub Chuncun1(Tkset As AcadSelectionSet)
Dim MDic1 As New Scripting.Dictionary, MDic2 As New Scripting.Dictionary
GetDicSet Tkset, MDic1
Throw MDic1, MDic2
ZitoExcel OutTextDic
ToExcel ExcelTextdic
End Sub
'存入ExcelTextdic公共字典
Public Sub Chuncun2(Tkset As AcadSelectionSet)
Dim MDic1 As New Scripting.Dictionary, MDic2 As New Scripting.Dictionary
GetDicSet Tkset, MDic1
Throw MDic1, MDic2
ZitoExcel OutTextDic
STMi = 0
Set OutTextDic = Nothing
End Sub
'经典算法，两字典相互扔数据模块
'经典算法，字典内嵌套字典
'Nothing 可选的。断绝 objectvar 与任何指定对象的关联。若没有其它变量指向 objectvar 原来所引用的对象，将其赋为 Nothing 会释放该对象所关联的所有系统及内存资源。
Public Sub Throw(MDic1 As Scripting.Dictionary, MDic2 As Scripting.Dictionary) '互扔模块
Dim Icount As Long, Jcount As Long
Dim j As Long, kk As Long
Dim Mpt1, Mpt2
Dim Dic1 As New Scripting.Dictionary, Dic2 As New Scripting.Dictionary
Set Dic1 = MDic1: Set Dic2 = MDic2
' On Error Resume Next
' Dim Min, Max, Min1, Max1
Do
Icount = Dic1.Count
Jcount = Dic2.Count
If Icount = 0 And Jcount = 0 Then Exit Do
STMi = STMi + 1 '此公共变量每递增一就遍历出来一个表格
' UserForm1.Caption = STMi
If Icount = 0 Then '由dic2扔到dic1
Do
ReDic Dic2
Px Dic2, 0
For j = 0 To Dic2.Count - 2
Mpt1 = Dic2(j).InsertionPoint
Mpt2 = Dic2(j + 1).InsertionPoint
If Mpt2(0) - Mpt1(0) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数
' Xbl = True
kk = Dic1.Count
For K = j + 1 To Dic2.Count - 1
Dic1.Add K - j - 1 + kk, Dic2(K)
Dic2.Remove (K)
Next
Exit For
End If
Next
If Not Blpxy(Dic2) Then
' For j = 0 To Dic2.Count - 1
OutTextDic.Add STMi, Dic2
'Next
Set Dic2 = Nothing
'Dic2.RemoveAll
Exit Do
End If
ReDic Dic2
Px Dic2, 1
For j = 0 To Dic2.Count - 2
Mpt1 = Dic2(j).InsertionPoint
Mpt2 = Dic2(j + 1).InsertionPoint
If Mpt1(1) - Mpt2(1) > Mjg Then
Ybl = True
kk = Dic1.Count
For K = j + 1 To Dic2.Count - 1
Dic1.Add K - j - 1 + kk, Dic2(K)
Dic2.Remove (K)
Next
Exit For
End If
Next
' For Each key In Dic1
' Debug.Print key & "--" & Dic1(key).TextString
' Next
If Not Blpxy(Dic2) Then
' For j = 0 To Dic2.Count - 1
OutTextDic.Add STMi, Dic2
'Next
Set Dic2 = Nothing
'Dic2.RemoveAll
Exit Do
End If
DoEvents
Loop
Else '由dic1扔到dic2 第二次开始外层循环肯定跳到此处（假设先开始第一个if条件的话）
Do
ReDic Dic1
Px Dic1, 0
For j = 0 To Dic1.Count - 2
Mpt1 = Dic1(j).InsertionPoint
Mpt2 = Dic1(j + 1).InsertionPoint
'Debug.Print "Mpt1 = " & Mpt1(0)
' Debug.Print "Mpt2 = " & Mpt2(0)
If Mpt2(0) - Mpt1(0) > Mjg Then
' Xbl = True
kk = Dic2.Count
For K = j + 1 To Dic1.Count - 1
Dic2.Add K - j - 1 + kk, Dic1(K)
Dic1.Remove (K)
Next
Exit For
End If
Next
' For Each Key In Dic1
' Debug.Print Key & "--" & Dic1(Key).TextString
' Next
If Not Blpxy(Dic1) Then
'For j = 0 To Dic1.Count - 1
OutTextDic.Add STMi, Dic1
' Next
Set Dic1 = Nothing
Exit Do
End If
ReDic Dic1
Px Dic1, 1
For j = 0 To Dic1.Count - 2
Mpt1 = Dic1(j).InsertionPoint
Mpt2 = Dic1(j + 1).InsertionPoint
If Mpt1(1) - Mpt2(1) > Mjg Then
Ybl = True
kk = Dic2.Count
For K = j + 1 To Dic1.Count - 1
Dic2.Add K - j - 1 + kk, Dic1(K)
Dic1.Remove (K)
Next
Exit For
End If
Next
If Not Blpxy(Dic1) Then
' For j = 0 To Dic1.Count - 1
OutTextDic.Add STMi, Dic1
'Debug.Print Dic1.Items(j).TextString & "--" & STMi
' Next
Set Dic1 = Nothing
Exit Do
End If
DoEvents
Loop
End If
DoEvents
Loop
' Throw Dic1, Dic2
End Sub
'递归将CAD图形内图元以坐标分堆同上面的功能一样,貌似耗费时间多一些
Public Sub Throw1(MDic1 As Scripting.Dictionary, MDic2 As Scripting.Dictionary) '互扔模块
Dim Icount As Long, Jcount As Long
Dim j As Long, kk As Long
Dim Mpt1, Mpt2
Dim Dic1 As New Scripting.Dictionary, Dic2 As New Scripting.Dictionary
Set Dic1 = MDic1: Set Dic2 = MDic2
' On Error Resume Next
' Dim Min, Max, Min1, Max1
Icount = Dic1.Count
Jcount = Dic2.Count
If Icount = 0 And Jcount = 0 Then Exit Sub
STMi = STMi + 1 '此公共变量每递增一就遍历出来一个表格
' Me.Caption = STMi
If Icount = 0 Then '由dic2扔到dic1
Do
ReDic Dic2
Px Dic2, 0
For j = 0 To Dic2.Count - 2
Mpt1 = Dic2(j).InsertionPoint
Mpt2 = Dic2(j + 1).InsertionPoint
If Mpt2(0) - Mpt1(0) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数
' Xbl = True
kk = Dic1.Count
For K = j + 1 To Dic2.Count - 1
Dic1.Add K - j - 1 + kk, Dic2(K)
Dic2.Remove (K)
Next
Exit For
End If
Next
If Not Blpxy(Dic2) Then
' For j = 0 To Dic2.Count - 1
OutTextDic.Add STMi, Dic2
'Next
Set Dic2 = Nothing
'Dic2.RemoveAll
Exit Do
End If
ReDic Dic2
Px Dic2, 1
For j = 0 To Dic2.Count - 2
Mpt1 = Dic2(j).InsertionPoint
Mpt2 = Dic2(j + 1).InsertionPoint
If Mpt1(1) - Mpt2(1) > Mjg Then
Ybl = True
kk = Dic1.Count
For K = j + 1 To Dic2.Count - 1
Dic1.Add K - j - 1 + kk, Dic2(K)
Dic2.Remove (K)
Next
Exit For
End If
Next
' For Each key In Dic1
' Debug.Print key & "--" & Dic1(key).TextString
' Next
If Not Blpxy(Dic2) Then
' For j = 0 To Dic2.Count - 1
OutTextDic.Add STMi, Dic2
'Next
Set Dic2 = Nothing
'Dic2.RemoveAll
Exit Do
End If
DoEvents
Loop
Else '由dic1扔到dic2 第二次开始外层循环肯定跳到此处（假设先开始第一个if条件的话）
Do
ReDic Dic1
Px Dic1, 0
For j = 0 To Dic1.Count - 2
Mpt1 = Dic1(j).InsertionPoint
Mpt2 = Dic1(j + 1).InsertionPoint
'Debug.Print "Mpt1 = " & Mpt1(0)
' Debug.Print "Mpt2 = " & Mpt2(0)
If Mpt2(0) - Mpt1(0) > Mjg Then
'Xbl = True
kk = Dic2.Count
For K = j + 1 To Dic1.Count - 1
Dic2.Add K - j - 1 + kk, Dic1(K)
Dic1.Remove (K)
Next
Exit For
End If
Next
If Not Blpxy(Dic1) Then
'For j = 0 To Dic1.Count - 1
OutTextDic.Add STMi, Dic1
' Next
Set Dic1 = Nothing
Exit Do
End If
ReDic Dic1
Px Dic1, 1
For j = 0 To Dic1.Count - 2
Mpt1 = Dic1(j).InsertionPoint
Mpt2 = Dic1(j + 1).InsertionPoint
If Mpt1(1) - Mpt2(1) > Mjg Then
Ybl = True
kk = Dic2.Count
For K = j + 1 To Dic1.Count - 1
Dic2.Add K - j - 1 + kk, Dic1(K)
Dic1.Remove (K)
Next
Exit For
End If
Next
If Not Blpxy(Dic1) Then
' For j = 0 To Dic1.Count - 1
OutTextDic.Add STMi, Dic1
'Debug.Print Dic1.Items(j).TextString & "--" & STMi
' Next
Set Dic1 = Nothing
Exit Do
End If
DoEvents
Loop
End If
DoEvents
Set MDic1 = Dic1: Set MDic2 = Dic2
Throw1 MDic1, MDic2
End Sub
'判断是否真正获得了一个表格，两个方向上面都没有间隙大于Mjg 的值就是一张表格
Public Function Blpxy(Pdic As Scripting.Dictionary) As Boolean '必须两个方向都没有间隙才能说明取出了一个表格，否则继续分
Dim j As Long, Xbl As Boolean, Ybl As Boolean
Dim Mpt1, Mpt2
ReDic Pdic
Px Pdic, 0
For j = 0 To Pdic.Count - 2
Mpt1 = Pdic(j).InsertionPoint
Mpt2 = Pdic(j + 1).InsertionPoint
' Debug.Print "Mpt1 = " & Mpt1(0)
' Debug.Print "Mpt2 = " & Mpt2(0)
If Mpt2(0) - Mpt1(0) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数
Xbl = True
Exit For
End If
Next
ReDic Pdic
Px Pdic, 1
For j = 0 To Pdic.Count - 2
Mpt1 = Pdic(j).InsertionPoint
Mpt2 = Pdic(j + 1).InsertionPoint
If Mpt1(1) - Mpt2(1) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数
Ybl = True
Exit For
End If
Next
If Xbl = False And Ybl = False Then
Blpxy = False
Else
Blpxy = True
End If
End Function
'初始化字典（因为从一个字典扔掉一部分后，字典的键值可能改变了，顺序也可能改变了
Public Sub ReDic(Mdic As Scripting.Dictionary)
Dim i As Long, Msp, Mstring As String
Dim Key
For Each Key In Mdic
Msp = Mdic(Key).InsertionPoint
Mstring = Msp(0) & "|" & Msp(1) & "|" & Msp(2)
Mdic.Key(Key) = Mstring
Next
End Sub
'从一个选择集里面获得文字字典
Public Sub GetDicSet(Tkset As AcadSelectionSet, Tkdic As Scripting.Dictionary)
Dim i As Long
Dim Mdic As New Scripting.Dictionary
Dim Inp, Mstring As String
For i = 0 To Tkset.Count - 1
Inp = Tkset(i).InsertionPoint
Mstring = Inp(0) & "|" & Inp(1) & "|" & Inp(2)
If Mdic.Exists(Mstring) Then
MsgBox "你的文字有重叠！重叠部分不计入计算！" & vbCrLf & "您可以使用CAD2012的Overkill命令删除后再统计！"
Else
Mdic.Add Mstring, Tkset(i)
End If
Next
Set Tkdic = Mdic
End Sub
'将数字作为键值,小字典键值都是数字
Public Sub Px(Tkdic As Scripting.Dictionary, Mflag As Integer) 'Mflag 0 对x排序，1，对Y排序，2对z排序
Dim i As Long, j As Long
Dim Icount As Long
Dim Inp1, Inp2, Tem As Long, ObjTem As AcadEntity
Dim Mi As Double, Mkey As String, Mkeys
Dim Msp1, Msp2, keytem As String, Mpd As Boolean
Icount = Tkdic.Count - 1
Mkeys = Tkdic.Keys
For i = 0 To UBound(Mkeys) - 1
For j = i + 1 To UBound(Mkeys)
Msp1 = Split(Mkeys(i), "|")
Msp2 = Split(Mkeys(j), "|")
If Mflag = 0 Then
Mpd = (Val(Msp1(Mflag)) > Val(Msp2(Mflag))) 'x小的前
ElseIf Mflag = 1 Then
Mpd = (Val(Msp1(Mflag)) < Val(Msp2(Mflag))) 'y大的在前
End If
If Mpd Then
keytem = Mkeys(i)
Mkeys(i) = Mkeys(j)
Mkeys(j) = keytem
End If
Next
Next
For i = 0 To UBound(Mkeys)
Tkdic.Key(Mkeys(i)) = i
Next
End Sub
'**************************************************************************************************************************
'经典算法直接求出其在excel表格内的位置
'分堆之后对每一堆对象进行表格排序
Public Sub ShituPx(ByRef Xzdic As Scripting.Dictionary, IRow As Long, ORow As Long)
Dim Inp1, Inp2, i As Long, j As Long, Icount As Long
Dim Ma1, Mi1, Ma2, Mi2
Dim MMbl As Boolean
MMbl = True
ReDic Xzdic
Px Xzdic, 0
Icount = Xzdic.Count
ExcelTextdic.Add Xzdic.Item(0), "1" '列
j = 1
For i = 0 To Icount - 2
If MMbl Then Xzdic.Item(i).GetBoundingBox Mi1, Ma1
Xzdic.Item(i + 1).GetBoundingBox Mi2, Ma2
If Not (Mi2(0) > Ma1(0) Or Mi1(0) > Ma2(0)) Then '盒子横向重叠,落入同一列
ExcelTextdic.Add Xzdic.Item(i + 1), CStr(j)
MMbl = False
Else
j = j + 1
ExcelTextdic.Add Xzdic.Item(i + 1), CStr(j)
MMbl = True
End If
Next
ReDic Xzdic
Px Xzdic, 1
' For Each Key In Xzdic
' Debug.Print Xzdic(Key).TextString & "--" & Key
' Next
j = 1 + IRow
MMbl = True
ExcelTextdic.Item(Xzdic.Item(0)) = CStr(j) & "|" & ExcelTextdic.Item(Xzdic.Item(0)) '行
For i = 0 To Icount - 2
Xzdic.Item(i).GetBoundingBox Mi1, Ma1
Xzdic.Item(i + 1).GetBoundingBox Mi2, Ma2
If Not (Mi2(1) > Ma1(1) Or Mi1(1) > Ma2(1)) Then '盒子竖向重叠，落入同一行
ExcelTextdic.Item(Xzdic.Item(i + 1)) = CStr(j) & "|" & ExcelTextdic.Item(Xzdic.Item(i + 1))
MMbl = False
Else
j = j + 1
ExcelTextdic.Item(Xzdic.Item(i + 1)) = CStr(j) & "|" & ExcelTextdic.Item(Xzdic.Item(i + 1))
MMbl = True
End If
Next
ORow = j
End Sub
' 将一堆东西分开后存入字典，属性值为i,j
Sub ZitoExcel(Dzdic As Scripting.Dictionary)
Dim Dkey, OutRow As Long
Static SubRow As Long
'SubRow = 0
For Each Dkey In Dzdic
ShituPx Dzdic(Dkey), SubRow, OutRow
' Debug.Print OutRow
SubRow = OutRow
Next
End Sub
'将由zitoexcel获得的字典输入的Excel
Public Sub ToExcel(Dzdic As Scripting.Dictionary)
On Error Resume Next
Dim Key, i As Long, j As Long, Tkbh As String
Dim Msp, xlApp, xlBook, xlSheet
Set xlApp = CreateObject("Excel.Application") '创建EXcel
xlApp.Visible = True
If Err.Number = 429 And VarType(xlApp) <> 9 Then '说明创建 Excel对象没有成功
Err.Number = 0
Set xlApp = CreateObject("ET.Application") '创建WPs
End If
If Err.Number = 429 And VarType(xlApp) <> 9 Then '说明创建 WPS对象没有成功
MsgBox "您的电脑上没有安装任何版本的EXCEL以及任何版本的WPS！" & vbCrLf & "所以不能使用本插件！", vbCritical, "江河梦小组"
Exit Sub
End If
If Dzdic.Count <> 0 Then
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
With xlSheet
For Each Key In Dzdic
Msp = Split(Dzdic(Key), "|")
i = Val(Msp(0)): j = Val(Msp(1))
If UBound(Msp) = 2 Then
Tkbh = Msp(2)
.Cells(i, j + 1) = IIf(IsNumeric(Key.TextString), "'" & Key.TextString, Key.TextString)
.Cells(i, 1) = Tkbh
Else
.Cells(i, j) = IIf(IsNumeric(Key.TextString), "'" & Key.TextString, Key.TextString)
End If
Next
End With
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End If
STMi = 0
Set OutTextDic = Nothing
Set ExcelTextdic = Nothing
End Sub
'*********************************************************************
Sub SSd(STRname As String)
Dim i As Integer
For i = 1 To ThisDrawing.SelectionSets.Count
If ThisDrawing.SelectionSets(i - 1).Name = STRname Then
ThisDrawing.SelectionSets(i - 1).Delete
Exit For
End If
Next
End Sub
'获得一个选择集字高的平均值
Public Function GetAH(Tkset As AcadSelectionSet) As Double
Dim Ent As AcadEntity, SubH As Double
For Each Ent In Tkset
SubH = SubH + Ent.Height
Next
If Tkset.Count = 0 Then
ThisDrawing.Utility.Prompt "你没有选择任何文字！"
Exit Function
End If
GetAH = SubH / Tkset.Count
End Function
'直接选择获得文字表格
Public Sub GetExcel(Optional TextBl As Double = 20)
Dim pTypey, pData, sset As AcadSelectionSet
SSd "ss6"
Set sset = ThisDrawing.SelectionSets.Add("ss6") '创建名为ss的选择集
BuildFilter pType, pData, 0, "*Text"
MM.Hide
sset.SelectOnScreen pType, pData '框选内容到选择集中(表格过滤)
Mjg = TextBl * GetAH(sset)
Chuncun1 sset
End Sub
'直接选择获得文字表格(考虑江河图框）
Public Sub GetTKExcel(Optional TextBl As Double = 20)
Dim pTypey, pData, Pt, Pd, SSet1 As AcadSelectionSet, SSet2 As AcadSelectionSet
Dim Tkent As AcadEntity, TextEnt As AcadEntity, Mstring As String, Att, Atts
Dim TkMa, TkMi
SSd "ss1"
Set SSet1 = ThisDrawing.SelectionSets.Add("ss1") '创建名为ss的选择集
SSd "ss2"
Set SSet2 = ThisDrawing.SelectionSets.Add("ss2") '创建名为ss的选择集
BuildFilter Pt, Pd, -4, "<or", 2, "TK-A[0-3]", 2, "TK-JG-A[3-4]", 2, "TK-MT-JT", 2, "TK-MT-LC", -4, "or>"
BuildFilter pType, pData, 0, "*Text"
MM.Hide
SSet1.SelectOnScreen Pt, Pd
For Each Tkent In SSet1
Mstring = ""
Atts = Tkent.GetAttributes()
For Each Att In Atts '遍历属性
If Trim(Att.TagString) = "图纸编号" Then
Mstring = Att.TextString
Exit For
End If
DoEvents
Next
Tkent.GetBoundingBox TkMi, TkMa
'Tkmi(2) = 0: TkMa(2) = 0
SSet2.Select acSelectionSetWindow, TkMi, TkMa, pType, pData
Mjg = TextBl * GetAH(SSet2)
Chuncun2 SSet2
For Each Key In ExcelTextdic
If UBound(Split(ExcelTextdic(Key), "|")) = 1 Then
ExcelTextdic(Key) = ExcelTextdic(Key) & "|" & Mstring
End If
Next
SSet2.Clear
Next
' For Each Key In ExcelTextdic
' Debug.Print Key.TextString & "--" & ExcelTextdic(Key)
' Next
ToExcel ExcelTextdic
SSet1.Delete
Set SSet1 = Nothing
Set SSet2 = Nothing
End
End Sub

'循环将CAD图形内图元以坐标分堆 
'华夏梦清 2012年7月11日，江河梦小组 
'循环x,y方向探测是否有距离大于Mjg的相邻文字，如果有那么将后面的去掉，然后（不管有没有）两个方向上是否有间隔大于Mjg的 
'如果没有跳出循环说明取出了了一张表格，然后继续递归此过程 
'************************************************************************************************************************** 
Public OutTextDic As New Scripting.Dictionary '储存的公共字典，返回数据，分堆储存 
Public ExcelTextdic As New Scripting.Dictionary '创建toexcel公共字典 
Public STMi As Long  '分出表格的个数 
Public Mjg As Double '水平竖直大于多少分隔为一个表格 
'直接导入Excel表格 
Public Sub Chuncun1(Tkset As AcadSelectionSet) 
   Dim MDic1 As New Scripting.Dictionary, MDic2 As New Scripting.Dictionary 
     GetDicSet Tkset, MDic1 
     Throw MDic1, MDic2 
       ZitoExcel OutTextDic 
       ToExcel ExcelTextdic 
End Sub 
'存入ExcelTextdic公共字典 
Public Sub Chuncun2(Tkset As AcadSelectionSet) 
   Dim MDic1 As New Scripting.Dictionary, MDic2 As New Scripting.Dictionary 
     GetDicSet Tkset, MDic1 
     Throw MDic1, MDic2 
       ZitoExcel OutTextDic 
       STMi = 0 
       Set OutTextDic = Nothing 
End Sub 
 
'经典算法，两字典相互扔数据模块 
'经典算法，字典内嵌套字典 
'Nothing 可选的。断绝 objectvar 与任何指定对象的关联。若没有其它变量指向 objectvar 原来所引用的对象，将其赋为 Nothing 会释放该对象所关联的所有系统及内存资源。 
Public Sub Throw(MDic1 As Scripting.Dictionary, MDic2 As Scripting.Dictionary)  '互扔模块 
   Dim Icount As Long, Jcount As Long 
   Dim j As Long, kk As Long 
   Dim Mpt1, Mpt2 
   Dim Dic1 As New Scripting.Dictionary, Dic2 As New Scripting.Dictionary 
   Set Dic1 = MDic1: Set Dic2 = MDic2 
  ' On Error Resume Next 
  ' Dim Min, Max, Min1, Max1 
   Do 
        Icount = Dic1.Count 
        Jcount = Dic2.Count 
        If Icount = 0 And Jcount = 0 Then Exit Do 
        STMi = STMi + 1 '此公共变量每递增一就遍历出来一个表格 
       ' UserForm1.Caption = STMi 
        If Icount = 0 Then '由dic2扔到dic1 
                 Do 
                   ReDic Dic2 
                   Px Dic2, 0 
                   For j = 0 To Dic2.Count - 2 
                       Mpt1 = Dic2(j).InsertionPoint 
                       Mpt2 = Dic2(j + 1).InsertionPoint 
                       If Mpt2(0) - Mpt1(0) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数 
                          ' Xbl = True 
                            kk = Dic1.Count 
                            For K = j + 1 To Dic2.Count - 1 
                                  Dic1.Add K - j - 1 + kk, Dic2(K) 
                                  Dic2.Remove (K) 
                            Next 
                            Exit For 
                       End If 
                   Next 
 
                       If Not Blpxy(Dic2) Then 
                           ' For j = 0 To Dic2.Count - 1 
                                OutTextDic.Add STMi, Dic2 
                            'Next 
                            Set Dic2 = Nothing 
                            'Dic2.RemoveAll 
                            Exit Do 
                       End If 
                   ReDic Dic2 
                   Px Dic2, 1 
                            
                   For j = 0 To Dic2.Count - 2 
                       Mpt1 = Dic2(j).InsertionPoint 
                       Mpt2 = Dic2(j + 1).InsertionPoint 
                       If Mpt1(1) - Mpt2(1) > Mjg Then 
                           Ybl = True 
                            kk = Dic1.Count 
                            For K = j + 1 To Dic2.Count - 1 
                                  Dic1.Add K - j - 1 + kk, Dic2(K) 
                                  Dic2.Remove (K) 
                            Next 
                            Exit For 
                       End If 
                   Next 
'                   For Each key In Dic1 
'                       Debug.Print key & "--" & Dic1(key).TextString 
'                   Next 
 
                      If Not Blpxy(Dic2) Then 
                           ' For j = 0 To Dic2.Count - 1 
                                OutTextDic.Add STMi, Dic2 
                            'Next 
                            Set Dic2 = Nothing 
                            'Dic2.RemoveAll 
                            Exit Do 
                      End If 
                   DoEvents 
 
                Loop 
 
           Else                       '由dic1扔到dic2 第二次开始外层循环肯定跳到此处（假设先开始第一个if条件的话） 
                 Do 
                   ReDic Dic1 
                   Px Dic1, 0 
                   For j = 0 To Dic1.Count - 2 
                       Mpt1 = Dic1(j).InsertionPoint 
                       Mpt2 = Dic1(j + 1).InsertionPoint 
                       'Debug.Print "Mpt1 = " & Mpt1(0) 
                       ' Debug.Print "Mpt2 = " & Mpt2(0) 
                       If Mpt2(0) - Mpt1(0) > Mjg Then 
                          ' Xbl = True 
                           kk = Dic2.Count 
                            For K = j + 1 To Dic1.Count - 1 
                                  Dic2.Add K - j - 1 + kk, Dic1(K) 
                                  Dic1.Remove (K) 
                            Next 
                            Exit For 
                       End If 
                   Next 
'                  For Each Key In Dic1 
'                       Debug.Print Key & "--" & Dic1(Key).TextString 
'                   Next 
                       If Not Blpxy(Dic1) Then 
                           'For j = 0 To Dic1.Count - 1 
                                OutTextDic.Add STMi, Dic1 
                           ' Next 
                            Set Dic1 = Nothing 
                            Exit Do 
                        End If 
                   ReDic Dic1 
                   Px Dic1, 1 
                   For j = 0 To Dic1.Count - 2 
                       Mpt1 = Dic1(j).InsertionPoint 
                       Mpt2 = Dic1(j + 1).InsertionPoint 
                       If Mpt1(1) - Mpt2(1) > Mjg Then 
                           Ybl = True 
                           kk = Dic2.Count 
                            For K = j + 1 To Dic1.Count - 1 
                                  Dic2.Add K - j - 1 + kk, Dic1(K) 
                                  Dic1.Remove (K) 
                            Next 
                            
                            Exit For 
                       End If 
                   Next 
 
                       If Not Blpxy(Dic1) Then 
                           ' For j = 0 To Dic1.Count - 1 
                                OutTextDic.Add STMi, Dic1 
                                 
                                'Debug.Print Dic1.Items(j).TextString & "--" & STMi 
                           ' Next 
                            
                            Set Dic1 = Nothing 
                            Exit Do 
                        End If 
                   DoEvents 
                Loop 
 
             End If 
             DoEvents 
        Loop 
             
            ' Throw Dic1, Dic2 
End Sub 
 
'递归将CAD图形内图元以坐标分堆 同上面的功能一样,貌似耗费时间多一些 
Public Sub Throw1(MDic1 As Scripting.Dictionary, MDic2 As Scripting.Dictionary)  '互扔模块 
   Dim Icount As Long, Jcount As Long 
   Dim j As Long, kk As Long 
   Dim Mpt1, Mpt2 
   Dim Dic1 As New Scripting.Dictionary, Dic2 As New Scripting.Dictionary 
   Set Dic1 = MDic1: Set Dic2 = MDic2 
  ' On Error Resume Next 
  ' Dim Min, Max, Min1, Max1 
        Icount = Dic1.Count 
        Jcount = Dic2.Count 
        If Icount = 0 And Jcount = 0 Then Exit Sub 
        STMi = STMi + 1 '此公共变量每递增一就遍历出来一个表格 
       ' Me.Caption = STMi 
        If Icount = 0 Then '由dic2扔到dic1 
                 Do 
                   ReDic Dic2 
                   Px Dic2, 0 
                   For j = 0 To Dic2.Count - 2 
                       Mpt1 = Dic2(j).InsertionPoint 
                       Mpt2 = Dic2(j + 1).InsertionPoint 
                       If Mpt2(0) - Mpt1(0) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数 
                          ' Xbl = True 
                            kk = Dic1.Count 
                            For K = j + 1 To Dic2.Count - 1 
                                  Dic1.Add K - j - 1 + kk, Dic2(K) 
                                  Dic2.Remove (K) 
                            Next 
                            Exit For 
                       End If 
                   Next 
 
                       If Not Blpxy(Dic2) Then 
                           ' For j = 0 To Dic2.Count - 1 
                                OutTextDic.Add STMi, Dic2 
                            'Next 
                            Set Dic2 = Nothing 
                            'Dic2.RemoveAll 
                            Exit Do 
                       End If 
                   ReDic Dic2 
                   Px Dic2, 1 
                            
                   For j = 0 To Dic2.Count - 2 
                       Mpt1 = Dic2(j).InsertionPoint 
                       Mpt2 = Dic2(j + 1).InsertionPoint 
                       If Mpt1(1) - Mpt2(1) > Mjg Then 
                           Ybl = True 
                            kk = Dic1.Count 
                            For K = j + 1 To Dic2.Count - 1 
                                  Dic1.Add K - j - 1 + kk, Dic2(K) 
                                  Dic2.Remove (K) 
                            Next 
                            Exit For 
                       End If 
                   Next 
'                   For Each key In Dic1 
'                       Debug.Print key & "--" & Dic1(key).TextString 
'                   Next 
 
                      If Not Blpxy(Dic2) Then 
                           ' For j = 0 To Dic2.Count - 1 
                                OutTextDic.Add STMi, Dic2 
                            'Next 
                            Set Dic2 = Nothing 
                            'Dic2.RemoveAll 
                            Exit Do 
                      End If 
                   DoEvents 
 
                Loop 
 
           Else                       '由dic1扔到dic2 第二次开始外层循环肯定跳到此处（假设先开始第一个if条件的话） 
                 Do 
                   ReDic Dic1 
                   Px Dic1, 0 
                   For j = 0 To Dic1.Count - 2 
                       Mpt1 = Dic1(j).InsertionPoint 
                       Mpt2 = Dic1(j + 1).InsertionPoint 
                       'Debug.Print "Mpt1 = " & Mpt1(0) 
                       ' Debug.Print "Mpt2 = " & Mpt2(0) 
                       If Mpt2(0) - Mpt1(0) > Mjg Then 
                           'Xbl = True 
                           kk = Dic2.Count 
                            For K = j + 1 To Dic1.Count - 1 
                                  Dic2.Add K - j - 1 + kk, Dic1(K) 
                                  Dic1.Remove (K) 
                            Next 
                            Exit For 
                       End If 
                   Next 
                       If Not Blpxy(Dic1) Then 
                           'For j = 0 To Dic1.Count - 1 
                                OutTextDic.Add STMi, Dic1 
                           ' Next 
                            Set Dic1 = Nothing 
                            Exit Do 
                        End If 
                   ReDic Dic1 
                   Px Dic1, 1 
                   For j = 0 To Dic1.Count - 2 
                       Mpt1 = Dic1(j).InsertionPoint 
                       Mpt2 = Dic1(j + 1).InsertionPoint 
                       If Mpt1(1) - Mpt2(1) > Mjg Then 
                           Ybl = True 
                           kk = Dic2.Count 
                            For K = j + 1 To Dic1.Count - 1 
                                  Dic2.Add K - j - 1 + kk, Dic1(K) 
                                  Dic1.Remove (K) 
                            Next 
                            
                            Exit For 
                       End If 
                   Next 
 
                       If Not Blpxy(Dic1) Then 
                           ' For j = 0 To Dic1.Count - 1 
                                OutTextDic.Add STMi, Dic1 
                                 
                                'Debug.Print Dic1.Items(j).TextString & "--" & STMi 
                           ' Next 
                            
                            Set Dic1 = Nothing 
                            Exit Do 
                        End If 
                   DoEvents 
                Loop 
 
             End If 
             DoEvents 
         Set MDic1 = Dic1: Set MDic2 = Dic2 
             
             Throw1 MDic1, MDic2 
End Sub 
'判断是否真正获得了一个表格，两个方向上面都没有间隙大于Mjg 的值就是一张表格 
Public Function Blpxy(Pdic As Scripting.Dictionary) As Boolean '必须两个方向都没有间隙才能说明取出了一个表格，否则继续分 
 Dim j As Long, Xbl As Boolean, Ybl As Boolean 
 Dim Mpt1, Mpt2 
 ReDic Pdic 
 Px Pdic, 0 
    For j = 0 To Pdic.Count - 2 
        Mpt1 = Pdic(j).InsertionPoint 
        Mpt2 = Pdic(j + 1).InsertionPoint 
'            Debug.Print "Mpt1 = " & Mpt1(0) 
'             Debug.Print "Mpt2 = " & Mpt2(0) 
        If Mpt2(0) - Mpt1(0) > Mjg Then  'TextH为平均字高，Doubli为自高的倍数 
            Xbl = True 
            Exit For 
        End If 
    Next 
     ReDic Pdic 
     Px Pdic, 1 
    For j = 0 To Pdic.Count - 2 
        Mpt1 = Pdic(j).InsertionPoint 
        Mpt2 = Pdic(j + 1).InsertionPoint 
        If Mpt1(1) - Mpt2(1) > Mjg Then 'TextH为平均字高，Doubli为自高的倍数 
            Ybl = True 
            Exit For 
        End If 
    Next 
    If Xbl = False And Ybl = False Then 
         Blpxy = False 
    Else 
         Blpxy = True 
    End If 
End Function 
'初始化字典（因为从一个字典扔掉一部分后，字典的键值可能改变了，顺序也可能改变了 
Public Sub ReDic(Mdic As Scripting.Dictionary) 
   Dim i As Long, Msp, Mstring As String 
   Dim Key 
   For Each Key In Mdic 
       Msp = Mdic(Key).InsertionPoint 
       Mstring = Msp(0) & "|" & Msp(1) & "|" & Msp(2) 
       Mdic.Key(Key) = Mstring 
   Next 
End Sub 
'从一个选择集里面获得文字字典 
Public Sub GetDicSet(Tkset As AcadSelectionSet, Tkdic As Scripting.Dictionary) 
    Dim i As Long 
    Dim Mdic As New Scripting.Dictionary 
    Dim Inp, Mstring As String 
    For i = 0 To Tkset.Count - 1 
        Inp = Tkset(i).InsertionPoint 
        Mstring = Inp(0) & "|" & Inp(1) & "|" & Inp(2) 
        If Mdic.Exists(Mstring) Then 
            MsgBox "你的文字有重叠！重叠部分不计入计算！" & vbCrLf & "您可以使用CAD2012的Overkill命令删除后再统计！" 
        Else 
            Mdic.Add Mstring, Tkset(i) 
        End If 
    Next 
   Set Tkdic = Mdic 
End Sub 
'将数字作为键值,小字典键值都是数字 
Public Sub Px(Tkdic As Scripting.Dictionary, Mflag As Integer)   'Mflag 0 对x排序，1，对Y排序，2对z排序 
    Dim i  As Long, j As Long 
    Dim Icount As Long 
    Dim Inp1, Inp2, Tem As Long, ObjTem As AcadEntity 
    Dim Mi As Double, Mkey As String, Mkeys 
    Dim Msp1, Msp2, keytem As String, Mpd As Boolean 
    Icount = Tkdic.Count - 1 
    
        Mkeys = Tkdic.Keys 
        For i = 0 To UBound(Mkeys) - 1 
            For j = i + 1 To UBound(Mkeys) 
                Msp1 = Split(Mkeys(i), "|") 
                Msp2 = Split(Mkeys(j), "|") 
                  If Mflag = 0 Then 
                      Mpd = (Val(Msp1(Mflag)) > Val(Msp2(Mflag))) 'x小的前 
                  ElseIf Mflag = 1 Then 
                     Mpd = (Val(Msp1(Mflag)) < Val(Msp2(Mflag))) 'y大的在前 
                  End If 
                If Mpd Then 
                    keytem = Mkeys(i) 
                    Mkeys(i) = Mkeys(j) 
                    Mkeys(j) = keytem 
                End If 
            Next 
        Next 
        For i = 0 To UBound(Mkeys) 
         Tkdic.Key(Mkeys(i)) = i 
        Next 
End Sub 
'************************************************************************************************************************** 
'经典算法直接求出其在excel表格内的位置 
'分堆之后对每一堆对象进行表格排序 
Public Sub ShituPx(ByRef Xzdic As Scripting.Dictionary, IRow As Long, ORow As Long) 
Dim Inp1, Inp2, i As Long, j As Long, Icount As Long 
Dim Ma1, Mi1, Ma2, Mi2 
Dim MMbl As Boolean 
MMbl = True 
    ReDic Xzdic 
    Px Xzdic, 0 
    Icount = Xzdic.Count 
    ExcelTextdic.Add Xzdic.Item(0), "1" '列 
    j = 1 
    For i = 0 To Icount - 2 
        If MMbl Then Xzdic.Item(i).GetBoundingBox Mi1, Ma1 
        Xzdic.Item(i + 1).GetBoundingBox Mi2, Ma2 
        If Not (Mi2(0) > Ma1(0) Or Mi1(0) > Ma2(0)) Then  '盒子横向重叠,落入同一列 
             ExcelTextdic.Add Xzdic.Item(i + 1), CStr(j) 
             MMbl = False 
        Else 
            j = j + 1 
            ExcelTextdic.Add Xzdic.Item(i + 1), CStr(j) 
            MMbl = True 
        End If 
    Next 
    ReDic Xzdic 
    Px Xzdic, 1 
'    For Each Key In Xzdic 
'        Debug.Print Xzdic(Key).TextString & "--" & Key 
'    Next 
        j = 1 + IRow 
        MMbl = True 
        ExcelTextdic.Item(Xzdic.Item(0)) = CStr(j) & "|" & ExcelTextdic.Item(Xzdic.Item(0)) '行 
        For i = 0 To Icount - 2 
            Xzdic.Item(i).GetBoundingBox Mi1, Ma1 
            Xzdic.Item(i + 1).GetBoundingBox Mi2, Ma2 
            If Not (Mi2(1) > Ma1(1) Or Mi1(1) > Ma2(1)) Then '盒子竖向重叠，落入同一行 
                 ExcelTextdic.Item(Xzdic.Item(i + 1)) = CStr(j) & "|" & ExcelTextdic.Item(Xzdic.Item(i + 1)) 
                 MMbl = False 
            Else 
                j = j + 1 
                ExcelTextdic.Item(Xzdic.Item(i + 1)) = CStr(j) & "|" & ExcelTextdic.Item(Xzdic.Item(i + 1)) 
                MMbl = True 
            End If 
        Next 
        ORow = j 
 
End Sub 
' 将一堆东西分开后存入字典，属性值为i,j 
Sub ZitoExcel(Dzdic As Scripting.Dictionary) 
 Dim Dkey, OutRow As Long 
 Static SubRow As Long 
    'SubRow = 0 
    For Each Dkey In Dzdic 
          ShituPx Dzdic(Dkey), SubRow, OutRow 
         ' Debug.Print OutRow 
          SubRow = OutRow 
    Next 
End Sub 
'将由zitoexcel获得的字典输入的Excel 
Public Sub ToExcel(Dzdic As Scripting.Dictionary) 
On Error Resume Next 
    Dim Key, i As Long, j As Long, Tkbh As String 
    Dim Msp, xlApp, xlBook, xlSheet 
        Set xlApp = CreateObject("Excel.Application") '创建EXcel 
        xlApp.Visible = True 
        If Err.Number = 429 And VarType(xlApp) <> 9 Then '说明创建 Excel对象没有成功 
             Err.Number = 0 
             Set xlApp = CreateObject("ET.Application") '创建WPs 
        End If 
        If Err.Number = 429 And VarType(xlApp) <> 9 Then '说明创建 WPS对象没有成功 
            MsgBox "您的电脑上没有安装任何版本的EXCEL以及任何版本的WPS！" & vbCrLf & "所以不能使用本插件！", vbCritical, "江河梦小组" 
            Exit Sub 
        End If 
        If Dzdic.Count <> 0 Then 
                Set xlBook = xlApp.Workbooks.Add 
                Set xlSheet = xlBook.Worksheets(1) 
                
                With xlSheet 
                For Each Key In Dzdic 
                    Msp = Split(Dzdic(Key), "|") 
                    i = Val(Msp(0)): j = Val(Msp(1)) 
                    If UBound(Msp) = 2 Then 
                         Tkbh = Msp(2) 
                         .Cells(i, j + 1) = IIf(IsNumeric(Key.TextString), "'" & Key.TextString, Key.TextString) 
                         .Cells(i, 1) = Tkbh 
                    Else 
                         .Cells(i, j) = IIf(IsNumeric(Key.TextString), "'" & Key.TextString, Key.TextString) 
                    End If 
                Next 
                End With 
                
                Set xlApp = Nothing 
                Set xlBook = Nothing 
                Set xlSheet = Nothing 
        End If 
       STMi = 0 
       Set OutTextDic = Nothing 
       Set ExcelTextdic = Nothing 
End Sub 
 
'********************************************************************* 
Sub SSd(STRname As String) 
  Dim i As Integer 
    For i = 1 To ThisDrawing.SelectionSets.Count 
        If ThisDrawing.SelectionSets(i - 1).Name = STRname Then 
            ThisDrawing.SelectionSets(i - 1).Delete 
            Exit For 
        End If 
    Next 
End Sub 
'获得一个选择集字高的平均值 
Public Function GetAH(Tkset As AcadSelectionSet) As Double 
    Dim Ent As AcadEntity, SubH As Double 
    For Each Ent In Tkset 
        SubH = SubH + Ent.Height 
    Next 
    If Tkset.Count = 0 Then 
       ThisDrawing.Utility.Prompt "你没有选择任何文字！" 
        Exit Function 
     End If 
    GetAH = SubH / Tkset.Count 
End Function 
'直接选择获得文字表格 
Public Sub GetExcel(Optional TextBl As Double = 20) 
  Dim pTypey, pData, sset As AcadSelectionSet 
    SSd "ss6" 
    Set sset = ThisDrawing.SelectionSets.Add("ss6") '创建名为ss的选择集 
    BuildFilter pType, pData, 0, "*Text" 
    MM.Hide 
    sset.SelectOnScreen pType, pData '框选内容到选择集中(表格过滤) 
    Mjg = TextBl * GetAH(sset) 
    Chuncun1 sset 
End Sub 
'直接选择获得文字表格(考虑江河图框） 
Public Sub GetTKExcel(Optional TextBl As Double = 20) 
  Dim pTypey, pData, Pt, Pd, SSet1 As AcadSelectionSet, SSet2 As AcadSelectionSet 
  Dim Tkent As AcadEntity, TextEnt As AcadEntity, Mstring As String, Att, Atts 
  Dim TkMa, TkMi 
    SSd "ss1" 
    Set SSet1 = ThisDrawing.SelectionSets.Add("ss1") '创建名为ss的选择集 
    SSd "ss2" 
    Set SSet2 = ThisDrawing.SelectionSets.Add("ss2") '创建名为ss的选择集 
    BuildFilter Pt, Pd, -4, "<or", 2, "TK-A[0-3]", 2, "TK-JG-A[3-4]", 2, "TK-MT-JT", 2, "TK-MT-LC", -4, "or>" 
    BuildFilter pType, pData, 0, "*Text" 
    MM.Hide 
    SSet1.SelectOnScreen Pt, Pd 
    For Each Tkent In SSet1 
          Mstring = "" 
          Atts = Tkent.GetAttributes() 
          For Each Att In Atts '遍历属性 
                If Trim(Att.TagString) = "图纸编号" Then 
                    Mstring = Att.TextString 
                    Exit For 
                End If 
                DoEvents 
          Next 
          Tkent.GetBoundingBox TkMi, TkMa 
          'Tkmi(2) = 0: TkMa(2) = 0 
          SSet2.Select acSelectionSetWindow, TkMi, TkMa, pType, pData 
          Mjg = TextBl * GetAH(SSet2) 
          Chuncun2 SSet2 
            For Each Key In ExcelTextdic 
                 If UBound(Split(ExcelTextdic(Key), "|")) = 1 Then 
                   ExcelTextdic(Key) = ExcelTextdic(Key) & "|" & Mstring 
                 End If 
            Next 
           SSet2.Clear 
    Next 
'    For Each Key In ExcelTextdic 
'         Debug.Print Key.TextString & "--" & ExcelTextdic(Key) 
'    Next 
    ToExcel ExcelTextdic 
    SSet1.Delete 
    Set SSet1 = Nothing 
    Set SSet2 = Nothing 
    End 
End Sub

xiabin68 · 发表于 2012-10-9 15:46:31

zml84 发表于 2012-10-9 13:04
本帖最后由 zml84 于 2012-10-9 13:05 编辑 (defun c:tt ()
(princ "\n请选择要排序的实体...")
...

经典，，，比我写的好多了，

crazylsp · 发表于 2012-10-9 16:55:07

精彩精彩......。
数字很连续，又是整数，视乎有还可以深化精简...。

自贡黄明儒 · 发表于 2012-10-12 23:10:09

http://bbs.mjtd.com/thread-96543-1-1.html
;;;143.1

zml84 · 发表于 2012-11-13 19:22:02

网友 ynhh 在6楼评论所言“容差”问题，请细看equal函数。

账号		自动登录	找回密码
密码			注册

图元排序问题

本帖子中包含更多资源

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

本帖子中包含更多资源

点评

点评

点评