excel - Trouble creating a 3D object using Loft command with two most recently created rectangles - Stack Overflow

admin管理员组

文章数量:1415484

I am continuously trouble in loft by using excel vba, especially in selectionset. What is the problem in under code?

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
    
    ' Connect to AutoCAD or start a new instance
    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
    
    ' Open a document or create a new one
    If acadApp.Documents.Count = 0 Then
        Set acadDoc = acadApp.Documents.Add
    Else
        Set acadDoc = acadApp.ActiveDocument
    End If
    
    ' Get the model space object
    Set modelSpace = acadDoc.ModelSpace
    
    ' Create 3 rectangles
    For i = 1 To 3
        x = i * 2 ' X coordinate
        y = i * 2 ' Y coordinate
        z = i * 2 ' Z coordinate (height)
        width = 5 - i ' Width
        height = 3 + i ' Height
        
        ' Define five vertices of the rectangle (last point should be the same as the first)
        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
        
        ' Draw the rectangle (3D polyline)
        Dim rect As Object
        Set rect = modelSpace.Add3DPoly(points)
        
        ' Add the created object to the list
        rectList.Add rect
    Next i
    
    ' Select the last two rectangles and perform Loft
    If rectList.Count >= 2 Then
        Dim rect1 As Object, rect2 As Object
        Set rect1 = rectList(rectList.Count - 1)
        Set rect2 = rectList(rectList.Count)
        
        ' Create a selection set and add objects
        Dim selSet As Object
        Set selSet = acadDoc.SelectionSets.Add("LoftSet")
        selSet.AddItems Array(rect1, rect2)
        
        ' Execute Loft command
        acadDoc.SendCommand "._loft " & vbCr & "S" & vbCr & vbCr & vbCr
        
        ' Delete the selection set
        selSet.Delete
    End If
    
    ' Display AutoCAD
    acadApp.Visible = True
    acadApp.ZoomExtents
    
    ' Clean up memory
    Set modelSpace = Nothing
    Set acadDoc = Nothing
    Set acadApp = Nothing
    Set rectList = Nothing
    
    MsgBox "Three rectangles have been drawn in AutoCAD, and Loft has been performed on the last two.", vbInformation
End Sub

本文标签：