Excel表轉出至CAD

在進行施工設計時，常使用Excel來進行數據的運算，常見有：

1. 主結構配筋的時候要試算鋼筋數量、長度、重量 → 鋼筋數量表
2. 主結構重要數量核算 → 材料數量表
3. 渠道使用明渠水理試算 → 水理因素表

當然需要的表格不僅有這些，還有拉力強度、彎距強度...等等的試算(在一些重要的結構物上)，但我也沒碰過故不清楚這部分。

在CAD中畫圖時，將Excel表轉至CAD檔方法有：

1. 利用AutoCAD插入表格，然後導入Excel檔。
2. 複製/貼上，將Excel要得區域複製，到AutoCAD中貼上。
3. 利用第三方軟體，做AutoCAD與Excel橋接。

詳細圖片說明請參考 ： 營建的馬克與電腦

筆者認為第三方軟體也是需要花錢的，故寫了個VBA供大家參考使用：

下載連結： ExcelToCAD_ConverceData.dvb

程式使用方法展示：

      1. 輸入你要前往的工作表位置(請輸入名稱索引,最前方的數字)，按下Enter

         ※如果偵測到工作表的頁數超過一頁的話才會啟動詢問

2. 直接選擇你要轉換的連結區域後，按下Enter

20190307更新:

上述的原始碼還是有一點寫太麻煩了，這次直接實作一個clsExcelToCAD物件並同時引用clsACAD物件，執行主要程序為ExportToCAD，偵測的內容是被框選到的儲存格，如果為合併儲存格則強迫畫外框，如果為單一儲存格則偵測是否上下左右邊界有無畫線，有畫線則有外框。

Private MyACAD As New clsACAD

Const TXT_COE = 0.8
Const ROW_COE = 0.335
Const COL_COE = 2.1

Public lupt As Variant
Private rng_start As Range
Private rng_end As Range
Private rng_first As Range

Sub ExportToCAD()

For Each rng In Selection

    If c = 0 Then Set rng_first = rng

    If rng.MergeCells Then
    
        Set ma = rng.MergeArea
    
        ma.Interior.ColorIndex = 41
        MergeTmp = Split(ma.Address, ":")
        
        Set rng_start = Range(MergeTmp(0)): Set rng_end = Range(MergeTmp(1))
        
        If rng.Address = rng_start.Address Then
        
            Call DrawTable(rng_start, rng_end)
        
        End If
        
        If rng.Address = rng_end.Address Then rng_start.Interior.ColorIndex = 0
        
    Else
    
        Call DrawTable(rng, rng)
        'Call DrawBorder(rng)
    
    End If

    c = c + 1

Next

End Sub

Sub DrawTable(ByVal rng_start As Range, ByVal rng_end As Range)

Dim txtpt(2) As Double
Dim ldpt(2) As Double
Dim rupt(2) As Double

txt_Height = rng_start.Font.Size
txt_String = rng_start.Value

CW = GetCW(rng_start, rng_end)
RH = GetRH(rng_start, rng_end)

txtpt(0) = rng_start.LEFT + CW / 2 + lupt(0)
txtpt(1) = -rng_start.Top - RH / 2 + lupt(1)

Set txtobj = MyACAD.AddMixText(txt_String, txtpt, txt_Height * TXT_COE, 2)

If rng_start = rng_end Then

    Call DrawBorder(rng_start)

Else

    ldpt(0) = rng_start.LEFT + lupt(0)
    ldpt(1) = -rng_start.Top + lupt(1)
    rupt(0) = rng_start.LEFT + CW + lupt(0)
    rupt(1) = -rng_start.Top - RH + lupt(1)
    
    Set Recobj = MyACAD.PlotRec(ldpt, rupt)

End If

End Sub

Sub DrawBorder(ByVal rng As Range)

Dim vertices(2 * 3 - 1) As Double

CW = GetCW(rng, rng)
RH = GetRH(rng, rng)

If rng.Borders(xlEdgeLeft).LineStyle <> -4142 And rng.LEFT = rng_first.LEFT Then

    vertices(0) = rng.LEFT + lupt(0): vertices(1) = -rng.Top + lupt(1)
    vertices(3) = vertices(0): vertices(4) = vertices(1) - RH
    
    Set plineobj = MyACAD.AddPolyLine(vertices)
    
End If

If rng.Borders(xlEdgeTop).LineStyle <> -4142 And rng.Top = rng_first.Top Then

    vertices(0) = rng.LEFT + lupt(0): vertices(1) = -rng.Top + lupt(1)
    vertices(3) = vertices(0) + CW: vertices(4) = vertices(1)
    
    Set plineobj = MyACAD.AddPolyLine(vertices)
    
End If

If rng.Borders(xlEdgeRight).LineStyle <> -4142 Then

    vertices(0) = rng.LEFT + lupt(0) + CW: vertices(1) = -rng.Top + lupt(1)
    vertices(3) = vertices(0): vertices(4) = vertices(1) - RH
    
    Set plineobj = MyACAD.AddPolyLine(vertices)
    
End If

If rng.Borders(xlEdgeBottom).LineStyle <> -4142 Then

    vertices(0) = rng.LEFT + lupt(0): vertices(1) = -rng.Top + lupt(1) - RH
    vertices(3) = vertices(0) + CW: vertices(4) = vertices(1)
    
    Set plineobj = MyACAD.AddPolyLine(vertices)
    
End If

End Sub

Function GetCW(ByVal rng1 As Range, ByVal rng2 As Range)

GetCW = rng2.Offset(0, 1).LEFT - rng1.LEFT

End Function

Function GetRH(ByVal rng1 As Range, ByVal rng2 As Range)

GetRH = rng2.Offset(1, 0).Top - rng1.Top

End Function

Private Sub Class_Initialize()

lupt = MyACAD.GetPoint("請點選表格的左上角點")

End Sub