AutoCAD VBA 縱斷面繪製自動化-1
範例影片：
成果圖：
緣由：
一般在設計小型工程時(尤其是筆者所接觸的水利工程方面，高程資料是非常重要的)，必須將樁號、單距、地盤高、挖填高or其他繪製成縱斷面圖，以往都是將前人留下的舊圖，一個一個慢慢編輯，但這實在不太方便，故透過AutoCADVBA去循序讀取Excel中的資料，達成在AutoCAD圖檔中縱斷面自動生成。 |
 |
| 是否呈現高程數字的部分可以在對話時將其關掉 |
緣由：
方法：
本次實作將分為在Excel中以及AutoCAD兩個部分。Excel中主要是要獲得樁號、單距、相關高程、坡度、長度、樁號說明、施工建議等項目。
Run的按鈕僅是提供首次接觸該VBA的人避免填錯資料的一個引導輸入介面。
Step1:決定設計起始點，輸入S,E or S,C,E
S代表開始的樁號、C代表變換坡度的樁號、E代表結束的樁號
Step2:是否需要清除Excel中的計畫高的欄位。
如果偵測到該設計起始點編碼上的計畫高的欄位還有保留數字，會依據這個數字來給予最適坡度。
Step3:輸入原先設定為起點的計畫高
Step4:由取得參考坡度，請求輸入一較接近為整數的坡度(1:XXX)
通常最適坡度都是抓計畫高到下一樁號的地盤高來計算，除非是在Step2有保留數字則會依據計畫高到下一樁號的計畫高來計算。
P.S:下一樁號為設計起始點的部分為"C"或者"E"的樁號
Step5.於該工作表的名稱後方刮弧內更改工程名稱(還沒寫進去...可忽略第5點)
Step6.如有需要再新增自己需要的判斷高度(如右田高、路面高...ETC)
如要新增自己的判斷高度，該欄位的名稱最後一定要是 "***高"才能被判斷
Step7.打開AutoCAD並開啟到為可以畫圖的圖面，點擊"畫圖"
請注意!!!這裡如果發現錯誤的話請檢查引用項目 ( VBA引用項目問題 )
或者是打開工作管理員 將所有的 "acad.exe" 結束工作(可能是開啟後隱藏在後台)
 |
| 因為我的是AutoCAD 2016，所以是引用 AutoCAD 2016 Type Library，每台電腦版本不同要往下找一下。 |
step8.第一列的Xscale代表X軸的比例，Yscale代表Y軸比例，基準點代表縱斷面表格在CAD左下角的位置。
Step9.可修改或不修改在縱斷面繪圖模組中有關畫圖class的程式碼參數(DrawLongtudinal)
此方法僅為初步設計，細部設計的問題再請參考(AutoCAD VBA 縱斷面自動化-常見問題)
HI 大大您好
回覆刪除我現在用您的程式碼有些問題
我將數據改成我的數據(只修改了樁號以及單距)
結果CAD把CPU吃滿 等了一整天(不誇張 大概5個小時) 還是畫不出來(大約7X個橫斷面)
可以告訴我要怎麼除錯嗎?
你好，我已經更新過程式碼了，再麻煩你再試看看
刪除你好
回覆刪除我在測試您的VBA檔案的時候
在
With Lsec 'unit mm
發生" 執行階段錯誤424,此處需要物件",的錯誤
我不知道怎麼除錯，麻煩您了
我想你的錯誤可能是因為版本不同的緣故，方便再多提供些相關資訊嗎?這樣比較有辦法知道錯誤在哪邊。
刪除果然是引用項目的CAD版本不對，已經能正常使用了，謝謝。
刪除有這個自動產生縱斷面，雖然沒有CIVIL 3D或者西谷功能這個強大，對小型工程足矣~
回覆刪除謝謝你的推薦。
刪除請問輸出到CAD的數字如何讓他取到小數點後第三位？
回覆刪除我不知道要修改哪一段程式碼，麻煩您了
在模組(縱斷面設計模組)裡面的Sub ChangeLoc裡面的
刪除d=Format(FrontLoc,"0+000")可以更改，如果要到第三位，改成
d=Format(FrontLoc,"0+000.000")
由於有多個路線，請問樁號的格式可否為A0+000，B0+000等格式?謝謝 !
回覆刪除可以，請聯繫我，apple84026113@gmail.com
刪除你好 將程式碼貼上 執行時會顯示使用者自定型尚未定義?請問該從何改起?
回覆刪除這表示你的版本可能沒有2016的library，檢查一下引用項目裡面有沒有缺漏
刪除作者已經移除這則留言。
回覆刪除請問可以分享程式嗎謝謝
回覆刪除jekyll159@gmail.com
請問可以分享程式嗎謝謝a0972152052@gmail.com
回覆刪除請問可以分享程式嗎???...非常感謝
回覆刪除a670927@yahoo.com.tw
a19780927@gmail.com
你好.請問可以分享程式?
回覆刪除qpbmoony@gmail.com
你好.請問可以分享程式? 感恩u010005@gmail.com
回覆刪除你好.請問可以分享程式嗎?非常感謝您~
回覆刪除danny27057767@gmail.com
可以分享程式嗎？工程需求～謝謝🙏
回覆刪除可以分享程式嗎？工程需求～謝謝🙏
回覆刪除chou790103@gmail.con
chou790103@gmail.com
回覆刪除請問可以分享程式嗎?非常感謝您~
回覆刪除zerozero6795@gmail.com
AutoCAD VBA 縱斷面繪製自動化，提升作業效率以節省時間確實好用。
回覆刪除版主，您好，謝謝您分享這麼好的資訊，可以向您請教一下，方便分享程式嗎？我的E-mail：back3338@gmail.com
回覆刪除可以分享程式嗎？工程需求～謝謝
回覆刪除cherry0903@gmail.com
竟然有這麼厲害的程式!!可以分享嗎？工程需求～謝謝
回覆刪除simon13016@gmail.com
請問可以分享程式嗎謝謝gary10206@hotmail.com
回覆刪除Sub writeexcel()
回覆刪除Dim excelapp As Excel.Application '定義excle應用程式變數
Dim excelsheet As worksheet '定義工作表變數
Dim ent As AcadBlockReference '定義塊屬性變數
Dim yline As Integer
Set excelapp = CreateObject("excel.application") '啟動excel程式
excelapp.Workbooks.Open (ThisDrawing.Path & "/物件長度test.xlsx") '打開工作薄
Set excelsheet = excelapp.ActiveWorkbook.Sheets("sheet1") '當前工作表為sheet1
yline = 1 '寫入行位置
For Each ent In ThisDrawing.ModelSpace '在模型空間裡迴圈
obname = ent.ObjectName '提取對象類型
If obname = "AcDbBlockReference" Then '判斷物件是否為塊
xy = ent.InsertionPoint '獲取插入點座標
varattr = ent.GetAttributes ' 將屬性標記和值複製到varattr變數
attrtxt0 = varattr(0).TextString '屬性值
attrtxt1 = varattr(1).TextString
excelsheet.Cells(yline, 1).Value = attrtxt0 '寫入excle文件
excelsheet.Cells(yline, 2).Value = attrtxt1
excelsheet.Cells(yline, 3).Value = xy(0)
excelsheet.Cells(yline, 4).Value = xy(1)
yline = yline + 1 '位置加一行
End If
Next
excelsheet.SaveAs "物件長度test.xlsx" '保存，檔案名是"物件長度test.xlsx"
excelapp.Quit '退出excel程式
Set excelapp = Nothing '釋放變數
Set excelsheet = Nothing
End Sub
你好,請教一下,程式構思：
開啟EXCEL檔,把CAD的屬性圖塊的標籤內容寫入EXCEL檔.
執行後出現:執行階段錯誤9:陣列索引超出範圍,
請問程式內容應該如何修改?
更新,上面問題已找到解決方法
回覆刪除