使用 VBA 从 AutoCAD 中的现有轮廓绘制新轮廓

Question

我正在使用 AutoCad 2021，我想从现有轮廓创建一个新轮廓，从现有轮廓下方 25 厘米开始，继续以 1% 的坡度直至与现有轮廓相交，然后垂直下降 25 厘米并继续以 1% 的坡度直到它与现有轮廓相交，然后重复直到现有轮廓的末尾。

我有下面的 VBA 代码，它不断地在“newProfile.AddVertex”行上给我错误，因为参数数量错误或属性分配无效。我非常感谢任何检查我的代码以使其正常工作的建议。

我正在 VBA 中尝试的自动化草图

Sub CreateNewProfile()
    Dim obj As AcadObject
    Dim existingProfile As AcadLWPolyline
    Dim newProfile As AcadLWPolyline
    Dim startPoint As Variant, endPoint As Variant
    Dim elevationChange As Double
    Dim slope As Double
    
    ' Set the elevation change and slope
    elevationChange = 25 ' in cm
    slope = 0.01 ' 1% slope
    
    ' Select the existing profile
    Set existingProfile = ThisDrawing.Utility.GetObject(, "Select existing profile:")
    
    ' Create a new profile
    Set newProfile = ThisDrawing.ModelSpace.AddLightWeightPolyline(existingProfile.Coordinates)
    
    ' Loop through each segment of the existing profile
    For i = 1 To existingProfile.NumberOfVertices - 1
        startPoint = existingProfile.Coordinates(i)
        endPoint = existingProfile.Coordinates(i + 1)
        
        ' Calculate the length and direction of the segment
        length = Sqr((endPoint(0) - startPoint(0)) ^ 2 + (endPoint(1) - startPoint(1)) ^ 2)
        angle = Atn((endPoint(1) - startPoint(1)) / (endPoint(0) - startPoint(0)))
        
        ' Create the new segments with the specified elevation change and slope
        newProfile.AddVertex startPoint(0), startPoint(1), startPoint(2) - elevationChange
        
        ' Calculate the endpoint of the first slope segment
        newX = startPoint(0) + (elevationChange / slope) * Cos(angle)
        newY = startPoint(1) + (elevationChange / slope) * Sin(angle)
        newProfile.AddVertex newX, newY, startPoint(2) - elevationChange
        
        ' Add the next vertex on the existing profile
        newProfile.AddVertex endPoint(0), endPoint(1), endPoint(2) - elevationChange
        
        ' Continue until the end of the existing profile
        If i < existingProfile.NumberOfVertices - 1 Then
            ' Calculate the endpoint of the vertical drop
            newX = endPoint(0) + elevationChange * Cos(angle)
            newY = endPoint(1) + elevationChange * Sin(angle)
            newProfile.AddVertex newX, newY, endPoint(2)
        End If
    Next i
    
    ' Close the new profile
    newProfile.Closed = True
    
    MsgBox "New profile created successfully!"
End Sub

Answer 1

您的代码似乎与您的措辞不符，我认为提供了正确的信息

首先，“参数数量错误或属性分配无效”错误是由于您不匹配

AddVertex()

方法“签名”，该方法需要“长整型”，然后是“双精度三元素数组”参数

然后您应该查看 LightWeight Polyline 对象的

Coordinates

属性的实际结果，该对象返回“二维点数组”

希望以下内容可以给您一个良好的起点

Option Explicit

Sub CreateNewProfile()

    On Error GoTo SafeExit
    
    ' Set the elevation change and slope
    Dim elevationChange As Double
        elevationChange = 25 ' in cm
    
    Dim slope As Double
        slope = 0.01 ' 1% slope
    
    ' Select the existing profile
    Dim existingProfile As AcadLWPolyline
        Dim basePnt As Variant
        ThisDrawing.Utility.GetEntity existingProfile, basePnt, "Select existing profile:"
    
    Dim nVertices As Long
        nVertices = 1 '(UBound(existingProfile.Coordinates) + 1) / 2
        
    ' Create a new profile
    Dim newProfile As AcadLWPolyline
        Set newProfile = ThisDrawing.ModelSpace.AddLightWeightPolyline(existingProfile.Coordinates)
    
        'set the starting point coordinates
        Dim x As Double, _
            y As Double
            x = existingProfile.Coordinates(0)
            y = existingProfile.Coordinates(1)
        
        Dim iVertex As Long
            iVertex = nVertices - 1
        
        'add the the starting point vertex
        Dim newVertex(0 To 1) As Double
            newVertex(0) = x: newVertex(1) = y
            iVertex = iVertex + 1
            newProfile.AddVertex iVertex, newVertex
            
        'update the new starting point coordinates
        y = y - elevationChange
        
        'add the new starting point as a new vertex
        newVertex(1) = y
        iVertex = iVertex + 1
        newProfile.AddVertex iVertex, newVertex
            
            Dim okLoop As Boolean
                Do
                    ' Create a temporary helper line to intersect with the existing polyline
                    Dim startPt(0 To 2) As Double
                    Dim endPt(0 To 2) As Double
                        startPt(0) = x: startPt(1) = y: startPt(2) = 0
                        endPt(0) = x + 10: endPt(1) = y + slope * 10: endPt(2) = 0
                    Dim lineObj As AcadLine
                        Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
                
                    ' Find the intersection points between the line and the circle
                    Dim intPoints As Variant
                        intPoints = lineObj.IntersectWith(existingProfile, acExtendThisEntity)
                    
                    ' look for any valid intersections
                    Select Case True
                    
                        Case VarType(intPoints) = vbEmpty
                            lineObj.Delete
                            Exit Do
                            
                        Case UBound(intPoints) = -1
                            lineObj.Delete
                            Exit Do
                            
                        Case Else ' there is a valid intersection
                            
                            ' add the intersection as the new vertex
                            newVertex(0) = intPoints(0): newVertex(1) = intPoints(1)
                            iVertex = iVertex + 1
                            newProfile.AddVertex iVertex, newVertex
                            
                            'delete the temporary helper line
                            lineObj.Delete
                            
                            'update the new starting point coordinates
                            x = newVertex(0)
                            y = newVertex(1) - elevationChange
                            
                            ' add the new starting point as a new vertex
                            newVertex(1) = y
                            iVertex = iVertex + 1
                            newProfile.AddVertex iVertex, newVertex
                            
                    End Select
                
                Loop While True
    
    newProfile.Closed = False
    
SafeExit:
    If Err.Number <> 0 Then
        MsgBox Err.Description
    Else
        MsgBox "New profile created successfully!"
    End If
End Sub