AutoCADVBA 圖紙小精靈_Ver1.0

前言：

有鑑於大部分前輩的圖都建立於模型空間(ModelSpace)之下，每次畫圖完畢發現少(多)某一張圖，當要插入或者是刪除時，就會需要在圖框內的頁次欄位進行更動，這點可以說是相當麻煩(尤其是對於超過30頁的圖檔來說)，因而引發筆者寫這篇Side Project供參考使用。

Demo影片：

使用方法：

1.程式介面建立於VBA之下，為一個dvb檔，有關如何開啟請參考(如何使用dvb檔)。

2.請檢查頁次項目部分為： 第OO頁共OO頁。

3.請檢查圖框圈選線是否為聚合線(連續線段)：偵測(LowerLeftPoint,UpperRightPoint)使用。

4.請檢查圖框圈選線所處圖層是否為 ( 出圖圖框 )：過濾圖框項目。

5.執行VBA巨集→點選第一個module(ShowUserForm)→執行。

圖一、紅色部分為圖框圈選線。


按鈕介紹：

1.創造圖框：若需要創建一連串的圖框們，可先在Excel檔中定義圖框內容後批次輸出。

圖二、圖框內容定義

2.新增圖紙：框選所有圖框，輸入要插入的頁次，會把所有框選起來的頁次及>=插入頁次的                           部分批次增加。

3.去除圖紙：框選所有圖框，輸入要刪除的頁次，會把所有框選起來的頁次及>=插入頁次的                           部分批次減少。

4.批次列印：必須先設定列印配置，請參考 (AutoCAD顧問-批次出圖 )

圖三、列印配置

注意事項：先選擇要輸出的印表機→出圖內容改為視窗(要求圈選時先隨意圈選)→置中出圖→比例為1:1→圖面方位(橫式)→如有需要再更改出圖型式表→套用至配置。

檔案下載：

本機端執行環境 AutoCAD2016 x64，Excel2016 x64，下載點： Frame.dvb

原始碼：

UserFrom比較沒東西就不放上來獻醜了。

比較重要的還是Module的部分：(其實是3個module改來改去，我把他合併起來丟上來而已)

Public wrkb As Object
Public wrks As Object
Public objexcel As Object
Public rng As Object
Public plineobj As AcadPolyline
Public lwplineobj As AcadLWPolyline '2D
Public txtobj As AcadText
Public lay As AcadLayer

Sub ShowUserForm()

UserForm1.show

End Sub

Sub ChangeFrame_Main(ByVal method As Integer)

Dim sset As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim PlotArr(1 To 100, 1 To 4) As Variant
Dim PlotArrFinal(1 To 100, 1 To 4) As Variant
Dim k As Integer

On Error Resume Next

ThisDrawing.SelectionSets("SS1").Delete

On Error GoTo 0

Set sset = ThisDrawing.SelectionSets.Add("SS1")

FilterType(0) = 8
FilterData(0) = "出圖圖框"

sset.SelectOnScreen FilterType, FilterData

For Each Item In sset

    Dim lwpline As AcadLWPolyline
    
    On Error GoTo ERROR_HANDLE
    
    Set lwpline = Item
        
    k = k + 1
    
    'Debug.Print "第" & k & "項目:"

    max_x = lwpline.Coordinates(0)
    max_y = lwpline.Coordinates(1)
    min_x = lwpline.Coordinates(0)
    min_y = lwpline.Coordinates(1)

    For i = 0 To 7
    
        co = lwpline.Coordinates(i)
        
        If i Mod 2 = 0 Then
        
            X = co
        
            If X > max_x Then max_x = X
        
            If X < min_x Then min_x = X
        
        Else
        
            Y = co
        
            If Y > max_y Then max_y = Y
        
            If Y < min_y Then min_y = Y
        
        End If
    
    Next
     
    PlotArr(k, 1) = max_x 'add data to an array
    PlotArr(k, 2) = max_y
    PlotArr(k, 3) = min_x
    PlotArr(k, 4) = min_y

    'Debug.Print max_x & vbCrLf & max_y & vbCrLf & min_x & vbCrLf & min_y

ERROR_HANDLE:

Next

On Error GoTo 0

Call AddFrame(PlotArr, method)

End Sub

Sub AddFrame(ByRef PlotArrFinal() As Variant, ByVal method As Integer)

Dim LowerLeft(0 To 2) As Double
Dim UpperRight(0 To 2) As Double
Dim sset As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant

If method = 1 Then

insertnum = InputBox("你要插入第幾張?", "圖紙小精靈對話小框框")

ElseIf method = 2 Then

insertnum = InputBox("你要扣除第幾張?", "圖紙小精靈對話小框框")

End If

insertnum = Val(insertnum)

For i = 1 To 100

    If PlotArrFinal(i, 3) = "" Then Exit For
    
    LowerLeft(0) = PlotArrFinal(i, 1)
    LowerLeft(1) = PlotArrFinal(i, 2)
    UpperRight(0) = PlotArrFinal(i, 3)
    UpperRight(1) = PlotArrFinal(i, 4)
    
    On Error Resume Next
    
    ThisDrawing.SelectionSets("SS1").Delete
    
    On Error GoTo 0
    
    Set sset = ThisDrawing.SelectionSets.Add("SS1")

    FilterType(0) = 0
    FilterData(0) = "Text"

    sset.Select acSelectionSetCrossing, LowerLeft, UpperRight, FilterType, FilterData

    For Each Item In sset
    
        txt = Item.TextString
    
        If txt Like "第*共*" Then
        
            'Debug.Print txt
            
            pt1 = InStr(1, txt, "頁")
            pt2 = InStr(pt1 + 1, txt, "頁")
            
            num1 = Val(Mid(txt, 2, pt1 - 2))
            
            If method = 1 Then
            
                If num1 >= insertnum Then num1 = num1 + 1
                
                num2 = Val(Mid(txt, pt1 + 2, pt2 - (pt1 + 2))) + 1
            
            ElseIf method = 2 Then
            
                If num1 >= insertnum Then num1 = num1 - 1
                
                num2 = Val(Mid(txt, pt1 + 2, pt2 - (pt1 + 2))) - 1
                
            End If
        
            'Debug.Print pt1 & " " & pt2 & " " & num1 & " " & num2
            
            Item.TextString = "第" & num1 & "頁共" & num2 & "頁"
        
        End If
    
    Next

Next

End Sub

Sub CreateFrame_Main(ByVal a As Integer)

Dim txtArr() As Variant
Dim ii As Integer

ret = ThisDrawing.Utility.GetPoint(, "請選擇圖框產生的起始點")

X = ret(0): Y = ret(1)
X_origin = X
Call GetExcel(wrks)

lr = wrks.cells(1, 3).End(-4121).row 'xldown=-4121
lc = wrks.cells(1, 1).End(-4161).column 'xltoright=-4161

ReDim txtArr(1 To lc, 1 To 2)

For r = 2 To lr

    For c = 1 To lc
    
        If wrks.cells(r, c) <> "" Then txtArr(c, 1) = wrks.cells(r, c)
        txtArr(c, 2) = wrks.cells(1, c)
        
    Next
    
    txtArr(lc, 1) = "第" & r - 1 & "頁共" & lr - 1 & "頁"
    
    If r > 2 Then X = X + 500
    
    If ii Mod 10 = 0 And ii <> 0 Then
        
        Y = Y - 500
        X = X_origin
    
    End If
    
    Call PlotFrameOuter(X, Y)
    
    Call PlotFrame(X, Y)
    
    Call PlotFrameInner(X, Y, txtArr)

    ii = ii + 1

Next

End Sub

Sub PlotFrameOuter(ByVal X As Double, ByVal Y As Double)

Dim txtpt(2) As Double
Dim vertices(5 * 2 - 1) As Double

vertices(0) = X - 20
vertices(1) = Y - 10

vertices(2) = X - 20
vertices(3) = Y + 277 + 10

vertices(4) = X + 390 + 10
vertices(5) = Y + 277 + 10

vertices(6) = X + 390 + 10
vertices(7) = Y - 10

vertices(8) = X - 20
vertices(9) = Y - 10

ThisDrawing.ActiveLayer = ThisDrawing.Layers("出圖圖框")

Set lwplineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(vertices)

ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")

txtpt(0) = X + 300
txtpt(1) = Y - 20

Set txtobj = ThisDrawing.ModelSpace.AddText("出圖圈選範圍線(A3)    297*420", txtpt, 5)

txtobj.color = acRed

End Sub

Sub PlotFrame(ByVal X As Double, ByVal Y As Double)

Dim vertices(5 * 3 - 1) As Double

vertices(0) = X
vertices(1) = Y

vertices(3) = X
vertices(4) = Y + 277

vertices(6) = X + 390
vertices(7) = Y + 277

vertices(9) = X + 390
vertices(10) = Y

vertices(12) = X - 0.8
vertices(13) = Y

Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)

plineobj.ConstantWidth = 1.6

End Sub

Sub PlotFrameInner(ByVal X As Double, ByVal Y As Double, ByRef txtArr() As Variant)

Dim vertices(3 * 2 - 1) As Double
Dim txtpt(2) As Double

arr = Array(60, 90, 70, 20, 20, 20, 20, 20, 20, 20, 30) '分割長度(由左到右)

For i = 1 To 2

    vertices(0) = X
    vertices(1) = Y + 9.25 * i
    
    vertices(3) = X + 390
    vertices(4) = Y + 9.25 * i
    
    Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)
    
    plineobj.ConstantWidth = 0.5
    
    Xt = vertices(0)
    
    For j = 0 To UBound(arr)
    
        Xt = Xt + arr(j)
    
        Xtt = Xt - 0.5 * arr(j)
    
        Yt = vertices(1) - 0.5 * 9.25
        
        txtpt(0) = Xtt
        txtpt(1) = Yt
        
        Set txtobj = ThisDrawing.ModelSpace.AddText(txtArr(j + 1, i), txtpt, 3.5) '文字高度3.5
        
        txtobj.Alignment = acAlignmentMiddleCenter
        txtobj.TextAlignmentPoint = txtpt
        
        
    Next
    
Next
    
For j = 0 To UBound(arr) - 1

        X = X + arr(j)
        
        vertices(0) = X
        vertices(1) = Y
        vertices(3) = X
        vertices(4) = Y + 18.5
        Set plineobj = ThisDrawing.ModelSpace.AddPolyline(vertices)
        plineobj.ConstantWidth = 0.5

Next

End Sub

Sub GetExcel(ByRef wrks As Object)

On Error Resume Next

Set objexcel = GetObject(, "Excel.Application")
If Err.Number > 0 Then
    Set objexcel = CreateObject("Excel.Application")
    Err.Clear
End If

Set wrkb = objexcel.ActiveWorkbook
Set wrks = objexcel.ActiveSheet

Set lay = ThisDrawing.Layers.Add("出圖圖框")

lay.color = acRed
lay.ViewportDefault = True

End Sub

Sub PrintOut_Main(ByVal a As Integer)

Dim sset As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim PlotArr(1 To 100, 1 To 4) As Variant
Dim PlotArrFinal(1 To 100, 1 To 4) As Variant
Dim k As Integer

On Error Resume Next

ThisDrawing.SelectionSets("SS1").Delete

On Error GoTo 0

Set sset = ThisDrawing.SelectionSets.Add("SS1")

FilterType(0) = 8
FilterData(0) = "出圖圖框"

sset.SelectOnScreen FilterType, FilterData

For Each Item In sset

    Dim lwpline As AcadLWPolyline
    
    On Error GoTo ERROR_HANDLE
    
    Set lwpline = Item
        
    k = k + 1
    
    'Debug.Print "第" & k & "項目:"

    max_x = lwpline.Coordinates(0)
    max_y = lwpline.Coordinates(1)
    min_x = lwpline.Coordinates(0)
    min_y = lwpline.Coordinates(1)

    For i = 0 To 7
    
        co = lwpline.Coordinates(i)
        
        If i Mod 2 = 0 Then
        
            X = co
        
            If X > max_x Then max_x = X
        
            If X < min_x Then min_x = X
        
        Else
        
            Y = co
        
            If Y > max_y Then max_y = Y
        
            If Y < min_y Then min_y = Y
        
        End If
    
    Next
     
    PlotArr(k, 1) = max_x 'add data to an array
    PlotArr(k, 2) = max_y
    PlotArr(k, 3) = min_x
    PlotArr(k, 4) = min_y

    'Debug.Print max_x & vbCrLf & max_y & vbCrLf & min_x & vbCrLf & min_y

ERROR_HANDLE:

Next

On Error GoTo 0

Call SortData(PlotArr, k, PlotArrFinal)

Call PrintOut(PlotArrFinal)

End Sub

Sub SortData(ByRef PlotArr() As Variant, ByVal k As Integer, ByRef PlotArrFinal() As Variant)

    order = 1
    p = 1

    For i = 1 To k
    
        min_x = PlotArr(i, 3)
        
        For j = order To k
        
            order_x = PlotArr(j, 3)
        
            If order_x < min_x Then min_x = order_x
        
        Next
        
        For n = 1 To k
        
            If PlotArr(n, 3) = min_x Then
            
                For z = 1 To 4
                
                    PlotArrFinal(p, z) = PlotArr(n, z) 'min
                    PlotArr(n, z) = PlotArr(i, z)
                    PlotArr(i, z) = PlotArrFinal(p, z)
                
                Next
                
                p = p + 1
                
                Exit For
            
            End If
        
        Next
    
        order = order + 1
    
    Next
    
End Sub

Sub PrintOut(ByRef PlotArrFinal() As Variant)

Dim LowerLeft(0 To 1) As Double
Dim UpperRight(0 To 1) As Double

Dim plotobj As AcadPlot

Dim lay As AcadLayout

Dim IfAsked As Boolean

Set lay = ThisDrawing.ActiveLayout

Set plotobj = ThisDrawing.Plot

'lay.ConfigName = "DWG to PDF.pc3"
'lay.CanonicalMediaName = "ISO_A3_(297.00_x_420.00_MM)"

IfAsked = False

For i = 1 To 100

    If PlotArrFinal(i, 3) = "" Then Exit For
    
    Debug.Print "第" & i & "張圖:列印程序 "
    
    LowerLeft(0) = PlotArrFinal(i, 1)
    LowerLeft(1) = PlotArrFinal(i, 2)
    UpperRight(0) = PlotArrFinal(i, 3)
    UpperRight(1) = PlotArrFinal(i, 4)
    
    lay.CenterPlot = True
    
    lay.PlotType = acWindow
    
    lay.SetWindowToPlot LowerLeft, UpperRight
    
    lay.GetWindowToPlot LowerLeft, UpperRight
    
    If IfAsked = False Then

        plotobj.DisplayPlotPreview acPartialPreview
        msg = MsgBox("請問該測試圖檔是不是正確的?", vbYesNo)
    
    End If
    
    If msg = vbYes Then
    
        plotobj.PlotToDevice

        IfAsked = True
        
    Else
    
        Exit Sub

    End If

Next

End Sub



留言

張貼留言

Popular Posts

Excel VBA @ 監造日報表、查驗表 -2

圖片
***如需施工日誌請參考 這裡 *** 20250106更新: 新的部落格連結 新版本20111214 已經更新!! 前言： 在經歷多次改版，發現使用的步驟還是有點多餘而且不夠自動化，此次將用物件類別模組的方式來修改Ver1.0留下尚可使用的程式碼，打造嶄新的監造日報表Ver2.0，輸出模式改為PDF，請搭配 PDFBinder 進行使用會比較方便。 準備文件： 以PCCES所編制並匯出成Excel之預算書報表 工程預算書中的數量計算表、土方計算表 監造日報表VBA使用手冊( 下載點我 ) 請開啟巨集並於login頁註冊後登入即可使用 圖一、Login頁面中點選註冊後跳至Google表單，填寫後即可以登入使用 參考文章： 專文1-PCCES處理到預算書 專文2-基本資料填寫 專文3-整個報表的靈魂 專文4-預定進度湊不到100%的解法  (20221204更新) 使用過程簡介： 1.  於工作表("Main")中填寫有關 工程名稱、 試體名稱(P.S.1) 、施工渠道名稱、進度資料等。 2.  於工作表("Budget")中點選"取得預算書"，修正為圖二所展示的內容。 圖二、取得預算書結果，如果需要整理準則，請參考設定準則的註解進行設定，並點選"重整準則" 3.  整理完成後並且更改為契約單價後，點選"匯出至報表"，資料會傳送至工作表("Main")，如下圖三所展示。 圖三、工作表("Main")中的報表資料，A~E欄為放置Step1 中的基本資料。 4.  於工作表("Records")中點選"填寫表單"，如圖四，即可進行一系列的資料紀錄，      為供應Diary及Check的基底資料。 圖四、施作項目來源是Main中的試體名稱與報表資料，如填寫資料有需要進行查驗，可以直接勾選(可複選) 5. 填寫完之後點選"傳送至Check"，再至工作表("Check")中點選"列印查驗"，     成果將輸出到該目錄下的查驗表Out...
Read more »

ExcelVBA@施工照片整理的應用範例

圖片
前言： 施工照片或者查驗照片對於許多工程人員來說，是個繁瑣的麻煩事。畢竟照片只是一張圖片，需要用人眼去判讀才有辦法了解內容是什麼，因為通常會有一張白板與工地現場進行合照，然而當撰寫白板的人寫字醜到不行時，會使人瘋狂。因此在施工照片的整理上，只要能解決 照片的資訊標示 與 報表位置自動貼附並調整大小 ，想必會讓各位有此類需求的工程人員節省許多時間。 相片的收集來源有以下方式 從相機的SD卡或手機連接USB直接進行下載，其檔案名稱通常為IMG_XXXX 或 DCIM_XXXX 。 透過LINE社群中建立相簿，並將同類屬性的照片丟進同一個相簿中，爾後再透過LINE電腦版將整本相簿進行下載，其檔案名稱通常為 LINE_ALBUM_相簿名稱_XXXX 。 上述兩種方式為筆者曾經使用過的方法，於資料夾檢視情況下僅有縮圖及沒有資訊標示的檔案名稱，需要雙擊展開大圖後才有辦法判讀該相片的用途，雖然上面有一張小白板的合照，但還是需要點開之後才有辦法了解內容是什麼，而【點開】並做【資訊標示】， 本身就是一件很麻煩的事 。 解決方案： 筆者的作法是將照片先整理至一個資料夾的底下，並透過LINE相簿在進行批次下載時指定其子資料夾名稱。之後便透過我所撰寫的【施工照片瀏覽及更名】的VBA小程式進行照片的資訊標示與報表輸出，詳細操作流程如下 點擊【取得資料夾】按鈕，選取已整理好的根資料夾位置。 點擊【貼上結果】按鈕，選取是否要在工作表上顯示縮圖及大小。 移動至工作表(Result)，若於工作表(Main)中有設定顯示大圖，則進入工作表(Result)中便會根據滑鼠選取的欄位顯示相對應的大圖資訊，並留有資訊標示欄位供使用者輸入做修改。 圖一、施工照片大圖資訊 有關施工照片資訊標示均輸入完畢之後，移動至工作表(Main)點擊【更換檔名】按鈕，以VBA可判讀的資訊標示的格式進行檔案名稱儲存，未來若有相對應的格式，系統會自動判讀並做預先設定，不用再輸入一次。 點擊【列印報表】按鈕，將會依照排序方法(時間或者項目)，依序將照片自動貼上於報表中並轉換成XLS或PDF， 製作成PDF才有辦法將檔案發布給其他人使用 ，如為XLS則會在自身電腦中並帶有照片原始檔的狀況下才能看到圖片。 圖三、施工照片報表輸出PDF模式。 圖三、施工照片報表輸出XLS。 若有施工照片需要的朋友們 施工照片VBA買斷版連結 *0313更...
Read more »

Excel表轉出至CAD

圖片
在進行施工設計時，常使用Excel來進行數據的運算，常見有： 主結構配筋的時候要試算鋼筋數量、長度、重量 → 鋼筋數量表 主結構重要數量核算 → 材料數量表 渠道使用明渠水理試算 → 水理因素表 當然需要的表格不僅有這些，還有拉力強度、彎距強度...等等的試算(在一些重要的結構物上)，但我也沒碰過故不清楚這部分。 在CAD中畫圖時，將Excel表轉至CAD檔方法有： 利用AutoCAD插入表格，然後導入Excel檔。 複製/貼上，將Excel要得區域複製，到AutoCAD中貼上。 利用第三方軟體，做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 ...
Read more »