使用 AutoCAD VBA 创建带有填充图案的矩形

Question

我正在尝试在 VBA 中使用 Excel 数据创建一个矩形，然后将生成的矩形导出到 AutoCAD 中。

下面的代码在 AutoCAD 中创建了矩形，但一直给我

无效的对象数组

对于

hatchObj.AppendOuterLoop

命令。

Option Explicit
'OWS Plan View
Sub DrawRectangleHatch()
    Dim AutocadApp As Object
    Dim AutocadDoc As Object
    Dim RectArray(0 To 9) As Double
    Dim rectangle As Object
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    Dim hatchObj As Object ' Autodesk.AutoCAD.Interop.Common.AcadHatch
    Dim outerLoop() As Variant ' Use Variant data type for array of Autocad entities
    
    ' Define the hatch
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True

    On Error Resume Next
    Set AutocadApp = GetObject(, "Autocad.Application")
    On Error GoTo 0

    If AutocadApp Is Nothing Then
        Set AutocadApp = CreateObject("Autocad.Application")
        AutocadApp.Visible = True
    End If

    'Point1
    RectArray(0) = ActiveSheet.Range("B22")
    RectArray(1) = ActiveSheet.Range("C22")
    'Point2
    RectArray(2) = ActiveSheet.Range("B23")
    RectArray(3) = ActiveSheet.Range("C23")
    'Point3
    RectArray(4) = ActiveSheet.Range("B24")
    RectArray(5) = ActiveSheet.Range("C24")
    'Point4
    RectArray(6) = ActiveSheet.Range("B25")
    RectArray(7) = ActiveSheet.Range("C25")
    'Point1
    RectArray(8) = ActiveSheet.Range("B26")
    RectArray(9) = ActiveSheet.Range("C26")

    On Error Resume Next
    Set AutocadDoc = AutocadApp.ActiveDocument
    On Error GoTo 0

    If AutocadDoc Is Nothing Then
        Set AutocadDoc = AutocadApp.Documents.Add
    End If

    Set rectangle = AutocadDoc.modelSpace.AddLightWeightPolyline(RectArray)

    'hatch grid
    Set hatchObj = AutocadDoc.modelSpace.AddHatch(PatternType, patternName, bAssociativity)

   ' Use the correct array declaration for the outerLoop
    ReDim outerLoop(0)
    Set outerLoop(0) = AutocadDoc.modelSpace.AddLightWeightPolyline(RectArray)
    hatchObj.AppendOuterLoop (outerLoop)

    hatchObj.Evaluate

    AutocadApp.ZoomExtents

    Set rectangle = Nothing
    Set AutocadApp = Nothing
    Set AutocadDoc = Nothing
End Sub

Answer 1

你能尝试一下吗？ 您可能还需要调整填充比例。在我的测试中，它只是一条可见的线，但它在那里没有错误。

Sub DrawRectangleHatch()
    Dim AutocadApp As AcadApplication
    Dim AutocadDoc As AcadDocument
    Dim RectArray(0 To 9) As Double
    Dim rectangle As AcadLWPolyline
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    Dim hatchObj As AcadHatch ' Autodesk.AutoCAD.Interop.Common.AcadHatch
    Dim OuterLoop(0 To 0) As AcadLWPolyline
    
    ' Define the hatch
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True

    On Error Resume Next
    Set AutocadApp = GetObject(, "Autocad.Application")
    On Error GoTo 0

    If AutocadApp Is Nothing Then
        Set AutocadApp = CreateObject("Autocad.Application")
        AutocadApp.Visible = True
    End If

    'Point1
    RectArray(0) = ActiveSheet.Range("B22")
    RectArray(1) = ActiveSheet.Range("C22")
    'Point2
    RectArray(2) = ActiveSheet.Range("B23")
    RectArray(3) = ActiveSheet.Range("C23")
    'Point3
    RectArray(4) = ActiveSheet.Range("B24")
    RectArray(5) = ActiveSheet.Range("C24")
    'Point4
    RectArray(6) = ActiveSheet.Range("B25")
    RectArray(7) = ActiveSheet.Range("C25")
    'Point1
    RectArray(8) = ActiveSheet.Range("B26")
    RectArray(9) = ActiveSheet.Range("C26")

    On Error Resume Next
    Set AutocadDoc = AutocadApp.ActiveDocument
    On Error GoTo 0

    If AutocadDoc Is Nothing Then
        Set AutocadDoc = AutocadApp.Documents.Add
    End If

    Set rectangle = AutocadDoc.ModelSpace.AddLightWeightPolyline(RectArray)

    'hatch grid
    Set hatchObj = AutocadDoc.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)

   ' Use the correct array declaration for the outerLoop
    Set OuterLoop(0) = AutocadDoc.ModelSpace.AddLightWeightPolyline(RectArray)
    hatchObj.AppendOuterLoop (OuterLoop)

    hatchObj.Evaluate

    AutocadApp.ZoomExtents

    Set rectangle = Nothing
    Set AutocadApp = Nothing
    Set AutocadDoc = Nothing
End Sub