CAD 选择集的问题，各位大神帮忙看下。

jepvyg · 发表于 2022-1-4 12:37:17

本帖最后由 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

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

guohq · 发表于 2022-2-5 15:09:23

通过交互方式进行选择时，要确保被选择的对象在视图范围内（即可见），不在范围内的对象经常选不中，注意到这点，选择应该不会出什么问题。

jepvyg · 发表于 2022-2-8 13:07:05

谢谢，就是你说的这个原因。
这个贴子我发错了位置。:P

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

CAD 选择集的问题，各位大神帮忙看下。

浏览过的版块