springwillow 发表于 2017-11-21 13:55:27

利用Excel的VBA操作CAD画图

在逛EH论坛的时候，发现了一段代码，读取单元格数据在CAD中画矩形，其实就是调用VBA画图，觉得还是蛮有意思的，发来这里给大家开拓思路。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(, "AutoCAD.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


luojie110 发表于 2017-11-22 11:30:02

抢一个沙发

QQ214189912 发表于 2017-11-28 09:42:50

                  谢谢分享

linyi9121 发表于 2017-12-5 09:46:17

页: [1]
查看完整版本: 利用Excel的VBA操作CAD画图