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 Double
    Dim startPoint(0 To 2) As Double
    Dim endPoint(0 To 2) As Double
    If R = 0 Or R = 180 Then
        x2 = X + l
        y2 = y
    End If
    If R = 90 Or R = 270 Then
        x2 = X
        y2 = y + l
    End If
    If R = -90 Or R = -270 Then
        x2 = X
        y2 = y - l
    End If
    startPoint(0) = X
    startPoint(1) = y
    endPoint(0) = x2
    endPoint(1) = y2
    Set o_Line = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    o_Line.color = yanse
End Sub

    然後，CAD中表格也需要輸出到Excel裏方便計算和存檔，其思路是：根據CAD所有文字的個數和橫、縱座標計算電子表格的範圍、行列間距，再將數字輸出到Excel各行各列中去。ExcelBookOpen自定義函數同上例代碼，以下程序均不再重複。

Public fn As Double
Private Sub CommandButton1_Click()          '建一個CommonDialog窗口方便打開Excel
    CommonDialog1.CancelError = False
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CBL = "Excel表格(*.xls;*.xlsx)|*.xls;*.xlsx|"
    CBL = CBL & "所有文件(*.*)|*.*|"
    CommonDialog1.Filter = CBL '過濾器
    CommonDialog1.FilterIndex = 1
    Me.CommonDialog1.InitDir = "D:\"
    Me.CommonDialog1.ShowOpen
    fn = Me.CommonDialog1.FileName
    fnposit = InStr(fn, "\")
    Text3.Text = fn                         'Excel文件位置
End Sub

Private Sub CommandButton2_Click()          '程序主題
    Dim dxf_code() As Integer, dxf_value() As Variant
    Dim sset As AcadSelectionSet
    Dim textObj As AcadText
    Dim minExt As Variant
    Dim maxExt As Variant
    Dim ExcelPath As String
    
    UserForm1.hide
    Set mybook = ExcelBookOpen(ExcelPath)
    Set mySheet = mybook.ActiveSheet
    If Text3.Text <> "" Then ExcelPath = Text3.Text Else ExcelPath = "D:\gj.xlsx": Text3.Text = "D:\gj.xlsx"
    For Each sset In ThisDrawing.SelectionSets
        If sset.Name = "SS1" Then
            ThisDrawing.SelectionSets.Item("SS1").Delete
            Exit For
        End If
    Next
    Set sset = ThisDrawing.SelectionSets.Add("SS1")
    ReDim dxf_code(0), dxf_value(0)
    dxf_code(0) = 0: dxf_value(0) = "TEXT"
    sset.SelectOnScreen dxf_code, dxf_value          '框選表格範圍

    Allrow = mySheet.Rows.Count
    Allcol = mySheet.Columns.Count
    ji = 0
    For Each textObj In sset
        textObj.GetBoundingBox minExt, maxExt        'CAD文字位置
        If ji = 0 Then xmin = minExt(0): xmax = maxExt(0): ymin = minExt(1): ymax = maxExt(1)  '尋找整個表格的範圍
        If minExt(0) < xmin Then xmin = minExt(0)
        If maxExt(0) > xmax Then xmax = maxExt(0)
        If minExt(1) < ymin Then ymin = minExt(1)
        If maxExt(1) > ymax Then ymax = maxExt(1)
        ji = ji + 1                                  '計數
    Next textObj
    xitv = (xmax - xmin) / Allcol        '獲得每列平均間距
    yitv = (ymax - ymin) / Allrow
    For Each textObj In sset
        ecol = Int(Abs(textObj.InsertionPoint(0) - xmin) / xitv) + 1    '文字定位在哪行哪列
        erow = Int(Abs(ymax - textObj.InsertionPoint(1)) / yitv) + 1
        If mySheet.cells(erow, ecol) = "" Then                          'CAD文字寫入Excel
            mySheet.cells(erow, ecol) = textObj.TextString
        Else
            mySheet.cells(erow, ecol) = mySheet.cells(erow, ecol) & textObj.TextString  '防止數據丟失
        End If
    Next textObj
    mybook.Close
End Sub

    現在，小夥伴們把兩個程序結合起來加個窗體，就可以很方便的實現Excel與CAD電子表格和互通啦。

 

面積統計

    日常建設類項目中常常涉及到徵地拆遷，需要統計地形圖中各類型建築拆遷面積工程量，由於佔地、平房、廠房等統計代碼爲本程序的簡單化版，在此不多做描述。具體思路是：統計樓房面積，在多段線範圍內搜索文字作爲樓層數，按照座標順序排號、輸出並計算結果。

Sub PLArea_3LouF()                        'CAD格式地形圖中統計樓房面積，並識別樓層
    Dim dxf_code() As Integer, dxf_value() As Variant
    Dim sset As AcadSelectionSet
    Dim ssetTxT As AcadSelectionSet
    Dim LWPolyObj As Object
    Dim PolyArea As Double
    Dim cadString As String
    Close #1
    For Each sset In ThisDrawing.SelectionSets    '圖形選擇集
        If sset.Name = "SS1" Then
            ThisDrawing.SelectionSets.Item("SS1").Delete
            Exit For
        End If
    Next
    For Each sset In ThisDrawing.SelectionSets    '文字選擇集
        If sset.Name = "SStext1" Then
            ThisDrawing.SelectionSets.Item("SStext1").Delete
            Exit For
        End If
    Next
    Set sset = ThisDrawing.SelectionSets.Add("SS1")
    Set ssetTxT = ThisDrawing.SelectionSets.Add("SStext1")
    sset.SelectOnScreen
    Open "d:\3樓房統計.txt" For Append As #1

    Dim ysumzu(0 To 1000) As Double
    Dim xsumzu(0 To 1000) As Double
    Dim dianzu(0 To 1000) As Double
    Dim numzu(0 To 1000) As Double
    Dim polyzu(0 To 1000) As Variant
    Dim Cengzu(0 To 1000) As Variant
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
    Dim Xmid, Ymid As Double
    Dim polyCoo As Variant
    xsum = 0: ysum = 0: dian = 0: num = 0 : Areasum = 0
    ff = InputBox("輸入上次統計暫停時的序號")

    For Each LWPolyObj In sset                  '初步獲得圖形面積數據
    If TypeOf LWPolyObj Is AcadPolyline Then
        If LWPolyObj.Area <> 0 Then
            Set polyzu(num) = LWPolyObj
            polyCoo = LWPolyObj.Coordinates
            For j = 0 To UBound(polyCoo) \ 2
                X = polyCoo(j * 2)
                Y = polyCoo(j * 2 + 1)
                xsum = xsum + X
                ysum = ysum + Y
                dian = dian + 1
            Next j
            ysumzu(num) = ysum
            xsumzu(num) = xsum
            dianzu(num) = dian
            numzu(num) = num
            LWPolyObj.Layer = "A樓房統計"		'將統計出的圖形更新到新建圖層中以區別
            LWPolyObj.color = acByLayer
            num = num + 1
        End If
        xsum = 0: ysum = 0: dian = 0
        sset.Update
    End If
    Next LWPolyObj

    For numt = 0 To num - 1                     '獲得樓層數據
        Xmid = xsumzu(numt) / dianzu(numt)
        Ymid = ysumzu(numt) / dianzu(numt)
        Mode = acSelectionSetCrossing
        Rang = polyzu(numt).Length / dianzu(numt) / 1.5       '點個數的2倍
        corner1(0) = Xmid + Rang: corner1(1) = Ymid + Rang: corner1(2) = 0
        corner2(0) = Xmid - Rang: corner2(1) = Ymid - Rang: corner2(2) = 0
        ReDim dxf_code(0), dxf_value(0)
        dxf_code(0) = 0: dxf_value(0) = "TEXT"
        ssetTxT.Select Mode, corner1, corner2, dxf_code, dxf_value    '在此樓房附近尋找樓層描述文字
        Cengzu(numt) = 0
        For Each PLTxtObj In ssetTxT
            If TypeOf PLTxtObj Is AcadText Then
                plwen = PLTxtObj.TextString
                If IsNumeric(plwen) And plwen > Cengzu(numt) Then Cengzu(numt) = plwen
            End If
        Next PLTxtObj
        If Cengzu(numt) = 0 Then Cengzu(numt) = 1
        plwen = ""
        ssetTxT.Clear
    Next numt
	
    Dim tobj(0 To 1) As Variant                '由於項目是縱向的，按照縱座標大小進行冒泡法排序
    Dim chu(0 To 1000) As Double
    For a = 0 To num - 2
        For b = a + 1 To num - 1
                chu(a) = xsumzu(a) / dianzu(a)            '按Y從小到大排序，若地形圖方向適合按x排序可改爲xsumzu(a)/dianzu(a)
                chu(b) = xsumzu(b) / dianzu(b)            '同上
                If chu(a) > chu(b) Then
                    temp = ysumzu(a): ysumzu(a) = ysumzu(b): ysumzu(b) = temp
                    temp = xsumzu(a): xsumzu(a) = xsumzu(b): xsumzu(b) = temp
                    temp = dianzu(a): dianzu(a) = dianzu(b): dianzu(b) = temp
                    temp = numzu(a): numzu(a) = numzu(b): numzu(b) = temp
                    temp = Cengzu(a): Cengzu(a) = Cengzu(b): Cengzu(b) = temp
                    Set tobj(0) = polyzu(a): Set polyzu(a) = polyzu(b): Set polyzu(b) = tobj(0)
                End If
        Next b
    Next a

    For i = 0 To num - 1
        PolyArea = polyzu(i).Area
        PolyArea = Format(PolyArea, "0.00")                 'txt中輸出精確面積
        PolyArea2 = Format(PolyArea, "0")                   'CAD上輸出模糊面積
        chu(i) = xsumzu(i) / dianzu(i) 
        If i > 1 Then
            If chu(i) = chu(i - 1) Then PolyArea = ""       '去除重合的
        End If
        cadString = Replace("New(" & i + ff & ")" & str(PolyArea2) & "層" & Cengzu(i), " ", "")   '序號
        HH = 2                                               '字高
        Set TextObj = AcadText(cadString, xsumzu(i) / dianzu(i), ysumzu(i) / dianzu(i), HH)
        Areasum = Areasum + Val(PolyArea)                    '求和
        Print #1, "New" & i + ff; " "; PolyArea; "層數"; Cengzu(i)  'txt格式輸出
    Next i
    Print #1, Areasum
    Print #1,
    Close #1
    sset.Delete
End Sub

Public Function AcadText(sText As String, X, Y, H)
    Dim o_Text As Object
    Dim InsertionPoint(0 To 2) As Double
    Dim alignmentPoint(0 To 2) As Double
    InsertionPoint(0) = X
    InsertionPoint(1) = Y + 3			'文字略在上顯示效果更好
    InsertionPoint(2) = 0
    sText = Trim(sText)
    Set o_Text = ModelSpace.AddText(sText, InsertionPoint, H)
    o_Text.Alignment = acAlignmentMiddleCenter
    o_Text.TextAlignmentPoint = InsertionPoint
    o_Text.color = acYellow             '與層數顏色不同，爲黃
    o_Text.Layer = "A樓房統計"          '文字所在圖層
    o_Text.ScaleFactor = 0.75           '寬度因子
    o_Text.Update
    Set AcadText = o_Text
End Function

 

圖框替換

    當項目圖框信息有變更、同一張圖可以適應不同項目時，就需要批量更新所有.dwg文件中的圖框圖形。一張圖中比例是固定的，因此一般需要修改的是圖形、文字內容。

    這裏的圖框有兩種情形：一. 圖框是單獨的的線段/多段線+文字 ；二. 整個圖框已被做成塊參照。

    情形一：單獨的文字或直線圖形替換都很簡單，只要找到被替換內容的固定特徵即可，簡要代碼如下。

Sub Text_Replace()    '普通文字替換
Dim Findstr As String
Dim Repstr As String
Dim ent As AcadEntity
Dim cadlujin As String
cadlujin = Dir("E:\所有圖2019\*.dwg", vbDirectory)
Do Until cadlujin = ""                                '遍歷文件夾內所有CAD圖紙
    ThisDrawing.Application.Documents.Open ("E:\所有圖2019\" & cadlujin)
    Findstr = "2019.05": Repstr = "2019.06"
    For Each ent In ThisDrawing.ModelSpace
        If TypeOf ent Is AcadText Or TypeOf ent Is AcadMText Then
            With ent
                If InStr(.TextString, Findstr) Then   '替換
                    .TextString = Replace(.TextString, Findstr, Repstr)
                End If
            End With
        End If
    Next
    cadlujin = Dir
Loop
End Sub

    情形二 (1)：圖框已經做成塊稍微複雜一點，如果替換部分不多，比如只替換塊中的文字，可以對症下藥，找到圖框的那個快，將塊炸開替換文字再修合成新塊。

Sub Block_Text_Replace()       '在塊中修改文字
Dim cadlujin , Findstr , Repstr As String
Dim BlockRef As AcadEntity
Dim BloNew As AcadBlock
Dim BloRefNew As AcadBlockReference
Dim exploObj As Variant
Dim ent() As Object
Dim k, j As Integer
j = 0
cadlujin = Dir("E:\所有圖\*.dwg", vbDirectory)
Do Until cadlujin = ""
    ThisDrawing.Application.Documents.Open ("E:\所有圖\" & cadlujin)
    Findstr = "2018.09": Repstr = "2018.10"
    For Each BlockRef In ThisDrawing.ModelSpace
        If TypeOf BlockRef Is AcadBlockReference Then
            If InStr(BlockRef.Name, "圖框") Then    '圖框塊的特徵：名爲圖框
                InPnt = BlockRef.InsertionPoint
                Set BloNew = ThisDrawing.Blocks.Add(InPnt, "新圖框")
                exploObj = BlockRef.Explode         '將塊炸開後再修改文字
                For k = 0 To UBound(exploObj)
                    If TypeOf exploObj(k) Is AcadText Or TypeOf exploObj(k) Is AcadMText Then
                        With exploObj(k)
                            If InStr(.TextString, Findstr) Then
                                .TextString = Replace(.TextString, Findstr, Repstr)
                            End If
                        End With
                    End If
                    ReDim Preserve ent(k)
                    Set ent(j) = exploObj(k)
                    j = j + 1
                Next k
                ThisDrawing.CopyObjects ent, BloNew  '複製塊
                Set BloRefNew = ThisDrawing.ModelSpace.InsertBlock(InPnt, "新圖框", 1, 1, 1, 0)   '創建新塊參照
                For kk = 0 To UBound(exploObj)
                    exploObj(kk).Delete  '刪除原炸開的對象
                Next kk
                BlockRef.Delete          '刪除原塊參照
                ReDim ent(0)
                j = 0
            End If
        End If
    Next
    ThisDrawing.PurgeAll                 '清理用不到的舊塊
    ThisDrawing.Close (True)             '保存關閉
    cadlujin = Dir
Loop
End Sub

    情形二 (2)：如果需要修改的東西實在太多，線段、文字一個個替換速度很慢，不如直接替換整個圖框塊。但是一張圖框的信息很多，不同的文件之間信息也不一樣，建議將需要替換的內容存在Excel或數據庫中，一併讀入CAD裏替換塊。本程序要求對CAD的對象、塊、塊參照都有一定的理解。

Sub Block_TiHuan()           '替代塊
	Dim cadlujin As String
	Dim ent As AcadEntity
	Dim etext As AcadEntity
	Dim BlockRefNew As AcadBlockReference
	Dim row As Integer
	Set mybook = ExcelBookOpen("d:\圖框 - YX - 副本.xlsx")
	Set mySheet = mybook.ActiveSheet
	row = 2
	cadlujin = Dir("E:\所有圖\*.dwg", vbDirectory)
Do Until cadlujin = ""
    ThisDrawing.Application.Documents.Open ("D:\真圖框A3.dwg")
    bilie = mySheet.cells(row, 3)              '需要替換的繪製比例、打印比例、圖名、圖表號、頁碼等信息存在Excel裏
    Tubiaohao = mySheet.cells(row, 5)
    Page1 = mySheet.cells(row, 7)
        If Len(Page1) = 1 Then Page11 = "0" & CStr(Page1) Else Page11 = CStr(Page1)
    TuBiLie = mySheet.cells(row, 9)
    For Each etext In ThisDrawing.ModelSpace
        If TypeOf etext Is AcadText Then
            If etext.TextString = "圖表號" Then
                etext.TextString = Tubiaohao
                etext.ScaleFactor = 0.5
                End If
            End If
            If etext.TextString = "第 01 頁" Then
                etext.TextString = "第 " & Page11 & " 頁"
            End If
            If etext.TextString = "1:10" Then
                etext.TextString = TuBiLie
            End If
            etext.Update
        End If
    Next
    ThisDrawing.SaveAs ("D:\新圖框" & ".dwg")
    ThisDrawing.Close (False)
    ThisDrawing.Application.Documents.Open ("E:\所有圖\" & cadlujin)
    For Each ent In ThisDrawing.ModelSpace
        If TypeOf ent Is AcadBlockReference Then
            If ent.Name = "圖框" Or ent.Name = "TK" Then
                pnt = ent.InsertionPoint
                Set BlockRefNew = ThisDrawing.ModelSpace.InsertBlock(pnt, "D:\新圖框" & ".dwg", bilie, bilie, bilie, 0)
                ent.Delete
            End If
        End If
    Next
    Kill ("D:\新圖框" & ".dwg")
    cadlujin = Dir
    row = row + 1
    ThisDrawing.PurgeAll
    ThisDrawing.Close (True)
Loop
row = row + 1
End Sub

    其他工作中常用到的代碼還有很多，基礎的數據文字處理、圖形處理、自動配筋、獲取信息打印等常規操作代碼將不再詳述，推薦一本二次開發學習材料《VBA開發人員手冊》，望有所幫助！