CAD 选择集的问题，各位大神帮忙看下。
本帖最后由 jepvyg 于 2022-1-4 12:46 编辑发错位置了，对不起各位。
这个程序准备用于图纸内的表格输出，本人水平有限，所以前期就是将表格中的多行文字转为单行文字，再将单行文字宽高比改小。最后，将整个表格的高度改为7，文字近似为3.5。这样处理后，再用贱人工具箱的功能，将表格输出。后期有时间再把贱人输出表格的功能加进去。
现在的问题是，现在的选择集不太靠谱：①第三次运行选择集时，在本地窗口中，发现预计框选的数量和sset选择集中的cout数量不一样，差好多，而且同一张表，复制几份，每份运行的结果都不一样（当然也有时，运行的结果是正确的）；②第二次运行选择集时，每次数量都不包括第一次选择集中新建的单行文字的数量。
Option Explicit
Public Sub MTextTotext()
On Error Resume Next
Dim ptInsert As Variant
Dim txtStr As String
Dim height As Double
Dim width As Double, bbg As Double
Dim k As Double, oScale As Double
Dim pt1, pt2, pt3
k = 0.4
'确定选择范围区以及表格现有的标高*********************************************
pt1 = ThisDrawing.Utility.GetPoint(, "框选左上角一个点: ")
pt2 = ThisDrawing.Utility.GetPoint(, "框选右下角一个点: ")
pt3 = ThisDrawing.Utility.GetPoint(, "将表格变成7mm高，选取左上角下方邻近点，以确定现有表格高度: ")
bbg = GetDistance(pt1, pt3)
Dim SSet As AcadSelectionSet
oScale = 7 / bbg
'选择多行文字*********************************************
'安全创建选择集
If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
Set SSet = ThisDrawing.SelectionSets.Item("this")
SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("this")
'定义过滤规则
Dim filterType(0) As Integer
Dim filterData(0) As Variant
filterType(0) = 0
filterData(0) = "MText"
SSet.Select acSelectionSetCrossing, pt1, pt2, filterType, filterData
'创建单行文字***************************************************************
Dim ptMin As Variant, ptMax As Variant
Dim objText As AcadText
Dim objMText As AcadMText
For Each objMText In SSet
'获得文字的主要参数
height = objMText.height
ptInsert = objMText.InsertionPoint
ptInsert(1) = ptInsert(1) - height
txtStr = MtextStringClearFormat(objMText.TextString)
'文字的限制框宽度
Set objText = ThisDrawing.ModelSpace.AddText(txtStr, ptInsert, height)
objText.ScaleFactor = k
objMText.Delete'删除原来的多行文字
Next
SSet.Delete
'第二步，在上一步的基础上，实现所有单行文字宽高比，变成K。
'安全创建选择集
If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
Set SSet = ThisDrawing.SelectionSets.Item("this")
SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("this")
'定义过滤规则,选持单行文字。
filterType(0) = 0
filterData(0) = "Text"
SSet.Select acSelectionSetCrossing, pt1, pt2, filterType, filterData
For Each objText In SSet
objText.ScaleFactor = k
Next
SSet.Delete
'第三步，表格整体缩放，在现在表格标高的基础上，将单表格高度整体缩放为7mm高，此时文字大概的高度为3.5mm，标准化后以便下一步操作。
'安全创建选择集
Dim objEnt As AcadEntity
If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
Set SSet = ThisDrawing.SelectionSets.Item("this")
SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("this")
SSet.Select acSelectionSetCrossing, pt1, pt2
For Each objEnt In SSet
objEnt.ScaleEntity pt1, oScale
Next
SSet.Delete
End Sub
Public Function MtextStringClearFormat(MTextString As String) As String '清除掉多行文字中的格式。
Dim MyString As String
MyString = MTextString
MyString = ReplaceByRegExp(MyString, "\\{", Chr(1))
MyString = ReplaceByRegExp(MyString, "\\}", Chr(2))
MyString = ReplaceByRegExp(MyString, "\\\\", Chr(3))
MyString = ReplaceByRegExp(MyString, "\\S([^;]*?)(\^|#)([^;]*?);", "$1$3")
MyString = ReplaceByRegExp(MyString, "\\S([^;]*?);", "$1")
MyString = ReplaceByRegExp(MyString, "(\\P|\\O|\\o|\\L|\\l|\{|\})", "")
MyString = ReplaceByRegExp(MyString, "\\[^;]*?;", "")
MyString = ReplaceByRegExp(MyString, "\x01", "{")
MyString = ReplaceByRegExp(MyString, "\x02", "}")
MyString = ReplaceByRegExp(MyString, "\x03", "\")
MtextStringClearFormat = Trim(MyString)
End Function
Public Function ReplaceByRegExp(ByVal Mystrig As String, ByVal TxtFind As String, ByVal TxtReplace As String)
Dim RE As Object
Set RE = ThisDrawing.Application.GetInterfaceObject("Vbscript.RegExp")
RE.IgnoreCase = False
RE.Global = True
RE.Pattern = TxtFind
ReplaceByRegExp = RE.Replace(Mystrig, TxtReplace)
Set RE = Nothing
End Function
'计算两点之间距离
Public Function GetDistance(sp As Variant, ep As Variant) As Double
Dim x As Double
Dim y As Double
Dim z As Double
x = sp(0) - ep(0)
y = sp(1) - ep(1)
z = sp(2) - ep(2)
GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function
通过交互方式进行选择时，要确保被选择的对象在视图范围内（即可见），不在范围内的对象经常选不中，注意到这点，选择应该不会出什么问题。 谢谢，就是你说的这个原因。
这个贴子我发错了位置。:P
页:
[1]