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