社区 › VBA/VB/ActiveX/API 编程技术 › 做了个CAD 输出表格的前置，有个选择集的问题，大神来看下。

jepvyg 发表于 2022-1-4 12:40:29

做了个CAD 输出表格的前置，有个选择集的问题，大神来看下。

这个程序准备用于图纸内的表格输出，本人水平有限，所以前期就是将表格中的多行文字转为单行文字，再将单行文字宽高比改小。最后，将整个表格的高度改为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

jepvyg 发表于 2022-1-4 13:41:44

本帖最后由 jepvyg 于 2022-1-4 13:44 编辑

发现太白了，改进了下，还是那个问题，好像对象多了，就选不中了，不知道，怎么办。
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)
   
    oScale = 7 / bbg
    Dim SSet As AcadSelectionSet
    '选择多行文字*********************************************安全创建选择集
    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   '**********注意了就是这个有问题。也注意过，pt1(2),pt2(2)是0.都在Z平面上。

    '创建单行文字***************************************************************
    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

    For Each objText In SSet
      '获得文字的主要参数
      objText.ScaleFactor = k   '单行文字宽度比例改为K
    Next

    Dim objEnt As AcadEntity
    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

jepvyg 发表于 2022-1-4 13:58:43

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=175903&highlight=%D1%A1%D4%F1%BC%AF
想不到自己找到原因了。
感谢http://www.mjtd.com/home.php?mod=space&uid=63914

664571221 发表于 2022-2-11 16:25:31

jepvyg 发表于 2022-1-4 13:58
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=175903&highlight=%D1%A1%D4%F1%BC%AF
想不到自己找到 ...

厉害楼主牛逼class

查看完整版本: 做了个CAD 输出表格的前置，有个选择集的问题，大神来看下。