CAD二次开发（VB）代码整理

    有时工作中在CAD上一笔一划设计图纸的重复动作，为了提高设计效率，我闲暇之余经常自己搞弄CAD二次开发，现在整理了一些平时项目中常用到的程序供大家参考使用，基本都是手打哦。

文章包含代码：

CAD连通Excel数据

面积统计

图框替换

---

CAD连通Excel数据

    很多Excel中计算后的新成果需要与CAD上工程量、坐标信息等表格来回修改，数据都是有的，那么如何编写代码实现这一的粘贴复制呢？

    首先，编写将Excel表格导入CAD中显示为直线与文字的组合，其思路是：获得Excel中行数、列数及间距，按照相应比例绘制表格横竖线，然后读取Excel数据对应位置写入为CAD文字。

Sub E_cad()
    Dim mybook As Object
    Dim mySheet As Object
    Dim txt As String
    Dim name As String
    Set mybook = ExcelBookOpen("d:\l-hang.xlsx")
    For n = 1 To 19
        Set mySheet = mybook.Sheets(n)
        colcount = mySheet.UsedRange.Columns.Count
        rowcount = mySheet.UsedRange.Rows.Count
        name = mySheet.cells(1, colcount)
        AcadText name, colcount * 8.5, -(n - 1) * 100 + 5, 5
        For col = 1 To colcount - 1         
            ColsW = ColsW + mySheet.Columns(col).ColumnWidth    '表格总列宽
        Next
        
        RowsH = (rowcount - 1) * 4.7 + 9.4                      '总高度
        AcadLine 0, -(n - 1) * 100 - RowsH, RowsH, 90, acBlue   '画初始竖线
        AcadLine 0, -(n - 1) * 100 - RowsH, ColsW, 0, acBlue    '画底部横线

        For col = 1 To colcount - 1
            ColW = mySheet.Columns(col).ColumnWidth             '单列宽
            For row = 1 To rowcount
                txt = mySheet.cells(row, col)
                If Len(txt) - Len(Replace(txt, ".", "")) >= 1 Then  '控制小数点位
                    txt = Format(txt, "0.00")
                End If
                ORowsH = mySheet.Rows(row).RowHeight            '单横高
                If row = 1 Then
                    AcadText txt, jColW + ColW / 2, -(n - 1) * 100 - ORowsH / 2, 3.5
                ElseIf row > 1 Then
                    AcadText txt, jColW+ColW/2, -(n - 1) * 100 - jRowH - ORowsH / 2, 3.5
                End If
                If col = 1 And row = 1 Then
                    AcadLine 0, -(n - 1) * 100, ColsW, 0, acBlue '画每行横线
                ElseIf col = 1 And row > 1 Then
                    AcadLine 0, -(n - 1) * 100 - 9.4 - (row - 2) * 4.7, ColsW, 0, acMagenta
                End If
                jRowH = jRowH + ORowsH
            Next
            jColW = jColW + ColW                                '累加列宽
            jRowH = 0
                If col = colcount - 1 Then                      '最后竖线
                    AcadLine jColW, -(n-1)*100 - RowsH, RowsH, 90, acBlue
                Else
                    AcadLine jColW, -(n-1)*100 - RowsH, RowsH, 90, acMagenta   '每列竖线
                End If
        Next
        jRowH = 0 : jColW = 0 : ColsW = 0
    Next
End Sub

Public Function ExcelBookOpen(FilePath As String)
    Dim o_Excel As Object
    Dim o_book As Object
    Set o_Excel = CreateObject("Excel.Application")     '建立电子表格实例
    o_Excel.Visible = True                              '设置可见
    Set o_book = o_Excel.Workbooks.Open(FilePath, 0)    '打开文件
    Set ExcelBookOpen = o_book                          '返回对象
End Function

Public Function AcadText(sText As String, X, y, h)      ' 添加单行文字
    Dim o_Text As Object
    Dim Location(0 To 2) As Double
    Location(0) = X
    Location(1) = y
    Set o_Text = ThisDrawing.ModelSpace.AddText(sText, Location, h)
    ' o_Text.Rotation = 0                   '角度
    o_Text.Alignment = 10                   '对齐方式（正中）
    o_Text.TextAlignmentPoint = Location    '对齐到指定点
    'o_Text.ObliqueAngle = 0                '倾斜
    o_Text.ScaleFactor = 0.75               '宽度因子
    o_Text.StyleName = "HZ"
    o_Text.color = acMagenta
    o_Text.Update
    Set AcadText = o_Text
End Function

Sub AcadLine(X, y, l, R, yanse)             '创建直线。x,y为起点坐标 ，l为长度，r为角度
    Dim o_Line As Object
    Dim x2 As Double
    Dim y2 As Doubl