获取CAD图形边界框(getboundingbox和getvariable)及字外加圆实例应用——vba实现

山水CAD插件定制

已于 2024-08-22 08:40:25 修改

阅读量1.4k

点赞数 13

CC 4.0 BY-SA版权

分类专栏： CAD VBA 文章标签：前端服务器 vba

于 2024-04-22 09:07:33 首次发布

本文链接：https://blog.youkuaiyun.com/yongshiqq/article/details/137912471

CAD VBA 专栏收录该内容

77 篇文章

订阅专栏

本文介绍如何使用VBA在AutoCAD中获取图形边界框，并通过实例演示了如何为文字实体添加圆形边界。文章提供了获取边界框的两种方法：getboundingbox方法和获取系统变量方法，并详细展示了循环字外加圆的具体实现。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

获取某个实体的边界框可用getboundingbox方法(注意：坐标需定义为变体变量variant)

Obj.GetBoundingBox minExt, maxExt

获取整图的边界框可用获取系统变量方法

youshang = ThisDrawing.GetVariable("extmax") '获取系统变量取得整图的边界
zuoxia = ThisDrawing.GetVariable("extmin")

代码如下：

Sub 获取边界框boundingbox()
    'yngqq443440204@2024年4月18日10:55:10
    ' 画条线获取边界框并取得边界框的左下角和右上角坐标(三维)
    Dim startPoint(0 To 2) As Double, endPoint(0 To 2) As Double
    Dim lineObj As AcadLine, youshang As Variant, zuoxia As Variant
    startPoint(0) = 2#: startPoint(1) = 2#: startPoint(2) = 0#
    endPoint(0) = 4#: endPoint(1) = 4#: endPoint(2) = 0#
    Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    ZoomExtents '缩放到范围
    Dim minExt As Variant, maxExt As Variant
    lineObj.GetBoundingBox minExt, maxExt
    ' 获取最小和最大范围
    MsgBox "线的边界范围是:" & vbCrLf _
         & "最小范围: " & minExt(0) & "," & minExt(1) & "," & minExt(2) _
         & vbCrLf & "最大范围: " & maxExt(0) & "," & maxExt(1) & "," & maxExt(2), vbInformation, "qq443440204"
    youshang = ThisDrawing.GetVariable("extmax") '获取系统变量取得整图的边界
    zuoxia = ThisDrawing.GetVariable("extmin")
MsgBox "OK，CAD二次开发qq:443440204", , "qq443440204"
    Stop
End Sub

结果如下：

通过系统变量的方法获取范围比getboundingbox方法获取范围略微大点。

以下为循环字外加圆实例：

Public Sub 循环字外加圆()
'yngqq443440204@2024年4月18日11:48:49
On Error GoTo errorcontrol
Do
Dim objText As AcadText, ptPick As Variant
ThisDrawing.Utility.GetEntity objText, ptPick, "拾取文字:"
Dim ptMin As Variant, ptMax As Variant
objText.GetBoundingBox ptMin, ptMax
Dim ptCenter(0 To 2) As Double
ptCenter(0) = (ptMin(0) + ptMax(0)) / 2
ptCenter(1) = (ptMin(1) + ptMax(1)) / 2
ptCenter(2) = 0
Dim radius As Double
radius = Sqr((ptMin(0) - ptMax(0)) ^ 2 + (ptMin(1) - ptMax(1)) ^ 2) / 2
Dim objCircle As AcadCircle
Set objCircle = ThisDrawing.ModelSpace.AddCircle(ptCenter, radius)
Loop
errorcontrol:
Err.Clear
MsgBox "OK，CAD二次开发qq:443440204", , "qq443440204"
Exit Sub
MsgBox "OK，CAD二次开发qq:443440204", , "qq443440204"
End Sub