使用Excel VBA调用AutoCAD Loft命令创建3D对象时遇问题

以下是你的代码中存在的核心问题，以及对应的修复方案：

1. 选择集重复创建导致报错 #

当宏重复运行时，acadDoc.SelectionSets.Add("LoftSet")会触发错误——因为同名的选择集已经存在于AutoCAD中。必须先检查选择集是否存在，存在则先清空或删除：

Dim selSet As Object
On Error Resume Next
Set selSet = acadDoc.SelectionSets.Item("LoftSet")
If Err.Number <> 0 Then
    Set selSet = acadDoc.SelectionSets.Add("LoftSet")
Else
    selSet.Clear ' 清空已有内容，避免残留对象
End If
On Error GoTo 0

2. SendCommand未关联选择集，导致Loft无对象可选 #

你创建了选择集，但没有让AutoCAD将其设为当前选中对象。直接发送Loft命令时，AutoCAD会等待用户手动选择，无法自动执行。解决方法是先将选择集设为当前选择：

' 将选择集设为AutoCAD当前选中对象
acadDoc.ActiveSelectionSet = selSet
' 调整Loft命令的输入流程，适配自动执行
acadDoc.SendCommand "._loft " & vbCr & vbCr & vbCr

流程说明：输入._loft后，第一个回车确认选择当前选中的对象（即选择集里的两个矩形），第二个回车表示不使用路径，第三个回车确认默认的Loft设置，完成自动创建。

3. 三维多段线未显式设置闭合 #

虽然代码中最后一点与第一点重合，但最好显式设置三维多段线为闭合状态，确保符合Loft对闭合轮廓的要求：

Set rect = modelSpace.Add3DPoly(points)
rect.Closed = True ' 强制设置为闭合

修复后的完整代码 #

Sub DrawRectanglesAndLoftInAutoCAD()
    Dim acadApp As Object
    Dim acadDoc As Object
    Dim modelSpace As Object
    Dim rectList As New Collection
    Dim x As Double, y As Double, z As Double, width As Double, height As Double
    Dim i As Integer
    
    ' 连接或启动AutoCAD
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    If acadApp Is Nothing Then
        Set acadApp = CreateObject("AutoCAD.Application")
    End If
    On Error GoTo 0
    
    ' 打开或新建文档
    If acadApp.Documents.Count = 0 Then
        Set acadDoc = acadApp.Documents.Add
    Else
        Set acadDoc = acadApp.ActiveDocument
    End If
    
    ' 获取模型空间
    Set modelSpace = acadDoc.ModelSpace
    
    ' 创建3个矩形
    For i = 1 To 3
        x = i * 2
        y = i * 2
        z = i * 2
        width = 5 - i
        height = 3 + i
        
        Dim points(0 To 14) As Double
        points(0) = x: points(1) = y: points(2) = z
        points(3) = x + width: points(4) = y: points(5) = z
        points(6) = x + width: points(7) = y + height: points(8) = z
        points(9) = x: points(10) = y + height: points(11) = z
        points(12) = x: points(13) = y: points(14) = z
        
        Dim rect As Object
        Set rect = modelSpace.Add3DPoly(points)
        rect.Closed = True ' 显式设置闭合
        
        rectList.Add rect
    Next i
    
    ' 对最后两个矩形执行Loft
    If rectList.Count >= 2 Then
        Dim rect1 As Object, rect2 As Object
        Set rect1 = rectList(rectList.Count - 1)
        Set rect2 = rectList(rectList.Count)
        
        ' 创建或复用选择集
        Dim selSet As Object
        On Error Resume Next
        Set selSet = acadDoc.SelectionSets.Item("LoftSet")
        If Err.Number <> 0 Then
            Set selSet = acadDoc.SelectionSets.Add("LoftSet")
        Else
            selSet.Clear
        End If
        On Error GoTo 0
        
        selSet.AddItems Array(rect1, rect2)
        acadDoc.ActiveSelectionSet = selSet
        
        ' 执行Loft命令
        acadDoc.SendCommand "._loft " & vbCr & vbCr & vbCr
        
        selSet.Delete
    End If
    
    acadApp.Visible = True
    acadApp.ZoomExtents
    
    ' 清理对象
    Set modelSpace = Nothing
    Set acadDoc = Nothing
    Set acadApp = Nothing
    Set rectList = Nothing
    
    MsgBox "已在AutoCAD中绘制3个矩形，并对最后两个执行Loft操作。", vbInformation
End Sub

内容的提问来源于stack exchange，提问作者jhwon