[原创]给text加框的程序

xuyajun1979

'文字画框
Sub WZhk()
  On Error Resume Next
 
  Dim mypnt1 As Variant
  Dim mypnt2  As Variant
    mypnt1 = ThisDrawing.Utility.GetPoint(, "请选择左下角点:")
    mypnt2 = ThisDrawing.Utility.GetCorner(mypnt1, "请选择右上角点:")

'crossing 方法选择所有内部对象
    Dim sset1 As AcadSelectionSet
    If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
        Set sset1 = ThisDrawing.SelectionSets.Item("SS1")
        sset1.Delete
    End If
    Set sset1 = ThisDrawing.SelectionSets.Add("SS1")

'定义过滤规则
    Dim filterType1(0) As Integer
    Dim filterData1(0) As Variant

    filterType1(0) = 0
    filterData1(0) = "TEXT"
    sset1.Select acSelectionSetCrossing, mypnt1, mypnt2, filterType1, filterData1 ' 使用Crossing选择模式，选择内部所有对象（包含边界本身）

    Dim ADTEXT As AcadText
    Dim MINPT As Variant
    Dim MAXPT As Variant
    Dim RECPL As AcadLWPolyline
    For Each ADTEXT In sset1
        ADTEXT.GetBoundingBox MINPT, MAXPT
        Set RECPL = 绘制矩形(MINPT, MAXPT, 0)
    Next
 
End Sub

ljttjl

给text和mtext文字同时加框程序演示如下：

 

unfeltboy

绘制矩形的函数呢？

e688w

通过对角两点绘制矩形的函数


  函数内容:

Function AddRectangle(varPnt1 As Variant, varPnt2 As Variant) As AcadLWPolyline

  On Error GoTo Err_Control
   
  Dim objSpace As AcadBlock
    If ThisDrawing.ActiveSpace = acModelSpace Then
      Set objSpace = ThisDrawing.ModelSpace
    Else
      Set objSpace = ThisDrawing.PaperSpace
    End If
      
    Dim plineObj As AcadLWPolyline
    Dim points(0 To 7) As Double
     
    points(0) = varPnt1(0): points(1) = varPnt1(1)
    points(2) = varPnt1(0): points(3) = varPnt2(1)
    points(4) = varPnt2(0): points(5) = varPnt2(1)
    points(6) = varPnt2(0): points(7) = varPnt1(1)
     
    Set plineObj = objSpace.AddLightWeightPolyline(points)

      plineObj.Closed = True
    Set AddRectangle = plineObj
            
Exit_Here:
  Exit Function
   
Err_Control:
  Resume Exit_Here

End Function


  

清风明月名字

加的方框角度是固定的0度，并不会随文字角度而变化