016集——n等分cad多段线、弧、圆等——vba实现

cad命令行输入"div"选择图元后可n等分图元，若图中有大量图元需要n等分，这时可借助vba一键实现。

代码逻辑框架为：通过创建句柄函数来选择实体，通过sendcommand函数向命令行输入命令。

先来个小程序练练手：在屏幕上指定两点划线，然后等分该线段。

Sub n等分cad多段线()
'2024年3月7日16:49:46 by qq:443440204
    Dim startPoint As Variant
    Dim endPoint As Variant
    Dim pp As Variant ''必须为变体变量，否则数组不能赋值
    Dim lineObj As AcadEntity
    Dim numSegments As Integer
    Dim lineHandle As String
    Dim divCommand As String
   numSegments = 20 ' 获取要等分的段数
   startPoint = thisdrawing.Utility.GetPoint(, "Enter start point: ")
   endPoint = thisdrawing.Utility.GetPoint(, "Enter end point: ")
   i1 = UBound(startPoint) - 1
   ReDim pp(i1) As Double ''只能为double,否则划线函数报错
   For i = 0 To UBound(startPoint) - 1
     pp(i) = startPoint(i)
   Next
   j = UBound(pp)
   i2 = j + UBound(endPoint)
   ReDim Preserve pp(i2) As Double
   For i = 0 To UBound(endPoint) - 1
     j = j + 1
     pp(j) = endPoint(i)
   Next
    ' 画线
    Set lineObj = thisdrawing.ModelSpace.AddLightWeightPolyline(pp)
    ' 获取线的LISP句柄
    lineHandle = obj2lsp(lineObj)
    ' 获取要插入的段数
    'numSegments = thisdrawing.Utility.GetInteger("Enter number of segments: ")
    '构建DIV命令的LISP字符串
    'divCommand = "_div " & lineHandle & vbCr & numSegments
    thisdrawing.SendCommand "_div "
    thisdrawing.SendCommand lineHandle & vbCr & numSegments & vbCr
MsgBox "已完成", , "版权@qq:443440204"
End Sub
Function obj2lsp(myobj As AcadEntity) As String
    Dim objHandle As String
    objHandle = myobj.Handle
    obj2lsp = "(handent " & Chr(34) & objHandle & Chr(34) & ")"
End Function

由下图可见，线画出来了，n等分的点也出来了。

继续升级一下代码功能，选择图中所有多段线、二维多线段、弧、圆、样条曲线、直线等，然后n等分：

Sub n等分cad多段线_弧_圆等()
'2024年3月7日16:49:46 by qq:443440204
Dim ent As AcadEntity
Dim numSegments As Integer
Dim lineHandle As String
Dim divCommand As String
Dim fy(0) As Integer, fd(0) As Variant
fy(0) = 0: fd(0) = "point"
Set sel = creatsel()
sel.Select acSelectionSetAll, , , fy, fd
Dim pt As AcadEntity
For Each pt In sel
     pt.Delete '等分之前先把图中所有点删除
Next
    ' 获取要插入的段数
numSegments = 12
On Error Resume Next
fy(0) = 0: fd(0) = "circle,*line,arc"
Set sel = creatsel()
sel.Select acSelectionSetAll, , , fy, fd
For Each ent In sel
    ' 获取线的LISP句柄
    lineHandle = obj2lsp(ent)
    ' 获取要插入的段数
    ' numSegments = thisdrawing.Utility.GetInteger("Enter number of segments: ")
    thisdrawing.SendCommand "_div "
    thisdrawing.SendCommand lineHandle & vbCr & numSegments & vbCr
Next
MsgBox "已完成", , "版权@qq:443440204"
End Sub
Function obj2lsp(myobj As AcadEntity) As String
    Dim objHandle As String
    objHandle = myobj.Handle
    obj2lsp = "(handent " & Chr(34) & objHandle & Chr(34) & ")"
End Function
Public Function creatsel() As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
   If Not IsNull(thisdrawing.SelectionSets.Item("mysel")) Then
       Set creatsel = thisdrawing.SelectionSets.Item("mysel")
       creatsel.Delete
''如果图中有名为"mysel"的选择集，那么把这个选择集放入sel中，然后删除这个选择集
    End If
''如果图中没有"mysel"，那么新建一个名为"mysel"的选择集，赋给sel这个对象
Set creatsel = thisdrawing.SelectionSets.Add("mysel")
End Function

见下图，所有图元已12等分。

原创代码，以上代码版权归本博所有，引用请注明连接。