[原创]给text加框的程序

xuyajun1979 发表于 2009-7-30 19:11:00

'文字画框 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 发表于 2009-7-30 20:14:00

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

unfeltboy 发表于 2009-7-31 16:16:00

绘制矩形的函数呢？

ntyks 发表于 2009-8-29 14:48:00

e688w 发表于 2011-6-13 13:17:24

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

函数内容:

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

清风明月名字 发表于 2012-4-20 17:47:46

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

页: [1]

明经CAD社区's Archiver

[原创]给text加框的程序