利用Excel的VBA操作CAD画图

Sub DrawRectangular()
    Dim aData, i&
    Dim acadApp As Object, acadDoc As Object
    Dim dPnts#(0 To 7), dPx#, dPy#, dCenter#(0 To 2), dHeight#
    
    aData = Sheets("Sheet1").Cells(1, 1).CurrentRegion ' 读取Excel数据
    
    Set acadApp = GetObject(, ".Application") ' 获得已经打开的AutoCAD程序的句柄
    Set acadDoc = acadApp.ActiveDocument ' 获得AutoCAD中当前文件的句柄
    
    dPx = 0: dPy = 0: dCenter(2) = 0: dHeight = 10
    ' dPx、dPy是矩形的左下角坐标；dCenter是矩形中心点数组；dHeight是文字高度
    For i = 1 To UBound(aData)
        dPnts(0) = dPx:               dPnts(1) = dPy
        dPnts(2) = dPx:               dPnts(3) = dPy + aData(i, 2)
        dPnts(4) = dPx + aData(i, 3): dPnts(5) = dPy + aData(i, 2)
        dPnts(6) = dPx + aData(i, 3): dPnts(7) = dPy
        ' 矩形的四个顶点坐标
        With acadDoc.ModelSpace.AddLightWeightPolyline(dPnts) ' 添加多义线联结4个顶点，三段
            .Closed = True ' 多义线封闭
        End With
        dCenter(0) = dPx + aData(i, 3) / 2: dCenter(1) = dPy + aData(i, 2) / 2
        ' 计算矩形的中心点坐标
        With acadDoc.ModelSpace.AddText(aData(i, 1), dCenter, dHeight) ' 添加文字至中心点
            .Alignment = 4 ' 文字的对齐方式是 Middle
            .TextAlignmentPoint = dCenter '更改对齐点坐标，否侧字会全插到原点去
        End With
        dPx = dPx + aData(i, 3) + 10 ' 下一个矩形的左下角坐标x轴偏移10
    Next
    Set acadDoc = Nothing: Set acadApp = Nothing
End Sub