| '執行下列的巨集會要求選取圖面上的物件，選完後會將「線性標註」及「對齊式標註」的測量值傳到一個新的 Excel 活頁簿內。 Sub SendDIM2Excel() Dim ssel As AcadSelectionSet Dim ett As AcadEntity Dim FilterType(0) As Integer Dim FilterData(0) As Variant FilterType(0) = 0 FilterData(0) = "DIMENSION" On Error Resume Next ThisDrawing.SelectionSets("Test").Delete On Error GoTo 0 Set ssel = ThisDrawing.SelectionSets.Add("Test") ssel.SelectOnScreen FilterType, FilterData If ssel.Count > 0 Then Dim xlapp As Object Dim xlbook As Object Dim rng As Object Set xlapp = CreateObject("Excel.Application") Set xlbook = xlapp.Workbooks.Add xlapp.Visible = True For Each ett In ssel If ett.ObjectName = "AcDbAlignedDimension" Or ett.ObjectName = "AcDbRotatedDimension" Then Set rng = xlbook.Sheets(1).Range("A65536").End(-4162).Offset(1, 0) rng = ett.ObjectName rng.Offset(0, 1) = ett.Measurement End If Next Set xlapp = Nothing Set xlbook = Nothing Set rng = Nothing End If ssel.Delete Set ssel = Nothing Set ett = Nothing End Sub |
2008年12月9日 星期二
將標註的測量值傳送到 Excel 活頁簿內
訂閱：
張貼留言 (Atom)
5 則留言:
您好，感謝您分享這麼方便的巨集^_^
想請問，如果我想把這巨集改成"將線或聚合線的長度"及"將聚合線或面域的面積"的值傳送到Excel活頁簿內，應該要改哪個變數呢?
又，不知道如果要學autocad vba的話，有哪些網路的學習資源呢?
謝謝~
你要同時選擇三種元件時，選擇集的過濾條件 filtertype 與 filterdata 這兩個變數的陣列要宣告到 5 個陣列元素，並依序存入對應的 DXF 群組碼，DXF 群組碼請到 Google 搜尋一下就可以找到資料。
我不知道哪兒有 Autocad VBA 的討論區，我剛學習 Autocad VBA 只有兩個月左右，目前的學習來源有二，一是 C:/Program Files/Common Files/Autodesk Shared 目錄裡面的 ACADAUTO.CHM 說明檔案，另一個是 Google 搜尋大神。
底下的程式碼大約就是你所說的「將線或聚合線的長度及聚合線或面域的面積的值傳送到Excel活頁簿內」，程式碼內有一個符號〈 你複製回去時得將它改為半形的符號，因為這個網頁不允許我輸入那的字元。
''''''建立選擇集並要求使用者選擇元件''''''''''
Dim FilterSet As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets("xxx").Delete
On Error GoTo 0
Set FilterSet = ThisDrawing.SelectionSets.Add("xxx")
'設定選擇集的過濾條件
Dim FilterType(0 To 4) As Integer
Dim FilterData(0 To 4) As Variant
FilterType(0) = -4
FilterType(1) = 0
FilterType(2) = 0
FilterType(3) = 0
FilterType(4) = -4
FilterData(0) = "〈or"
FilterData(1) = "Line"
FilterData(2) = "LWPolyLine"
FilterData(3) = "ReGion"
FilterData(4) = "or>"
'使用者在圖面上選擇元件
FilterSet.SelectOnScreen FilterType, FilterData
'沒選到任何元件時直接離開巨集
If FilterSet.Count = 0 Then
MsgBox "沒有選取任何線、聚合線或面域。"
Set FilterSet = Nothing
Exit Sub
End If
''''''開始準備將選到的元件的屬性一一寫入 Excel''''''''''
Dim i As Integer
Dim cadobj As AcadEntity
Dim xlapp As Object
Dim xlbk As Object
Dim r As Long
'取得已經開啟的 Excel 主程式
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
On Error GoTo 0
'如果 Excel 沒開啟的話，開啟 Excel 並顯示出來
If xlapp Is Nothing Then
Set xlapp = CreateObject("Excel.Application")
End If
xlapp.Visible = True
'在 Excel 新增一個空白的活頁簿
Set xlbk = xlapp.Workbooks.Add
'在 Sheet1 的第一列寫上標題
With xlbk.Sheets(1)
.Cells(1, 1) = "類型"
.Cells(1, 2) = "圖層"
.Cells(1, 3) = "長度"
.Cells(1, 4) = "面積"
r = 1
'依序寫入 Cad 元件的類型、圖層、長度、標題
On Error Resume Next
For Each cadobj In FilterSet
r = r + 1
.Cells(r, 1) = cadobj.ObjectName
.Cells(r, 2) = cadobj.Layer
.Cells(r, 3) = cadobj.Length
.Cells(r, 4) = cadobj.Area
Next
On Error GoTo 0
End With
'釋放物件變數
Set FilterSet = Nothing
Set cadobj = Nothing
Set xlapp = Nothing
Set xlbk = Nothing
剛剛試成功了！這巨集真的會幫我省下很多作業時間。
再次感謝您無私的分享~
無限感恩～
您好!!
很驚豔這巨集的強大威力
試了一下
發現這威力可以讓我算挖填方速度加倍!!
但是想請教一下
這面積匯到excel 是一個個的面積
如何修改這vba 先讓他做加總呢?
一次選擇一次加總的方式~
這功能能有快捷鍵嗎?做成icon嗎?
譬如
^[^[(command "_vbarun" "getentity")
對於vba我第一次接觸!!
我是咕狗大神牽引我到這裡的!!
再此先謝謝您!!
請問
我想把CAD圖中空間名稱及面積資料一起轉至EXCEL不知可行嗎?
張貼留言