[教學]VBA 基本程式 拉泡泡 001
5 posters
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第2頁(共2頁)
[教學]VBA 基本程式 拉泡泡 001
主題回顧 :
' Autocad 的 VBA help 其實就寫的很清楚, 範例也很多, 但都是英文的.
' 基本寫法跟 VB6 差不多, 所以可以參考 VB6 的書, 別人不要的 VB6 書本, 可以拿來看看.
Option Explicit ' 一定要定義變數
Public Sub bubble_line() ' bubble_line 程式名稱可以自己取
On Error Resume Next ' 如果有錯誤, 不管他
Dim line_obj As AcadLine ' 定義線的變數名稱
Dim cir_obj As AcadCircle ' 定義圓的變數名稱
Dim p1 As Variant ' 定義 拉泡泡起點的變數名稱
Dim p2 As Variant ' 定義 拉泡泡終點的變數名稱
Dim int_p As Variant ' 定義 拉泡泡直線跟泡泡交點的變數名稱
Dim bubble_number As Integer ' 定義泡泡號碼的名稱
Dim text_obj As AcadText ' 定義泡泡號碼寫入文字的變數名稱
' Thisdrawing 是現在這張圖紙的意思, Utility : VBA 輸入資料等都在這一類, 公用程式
p1 = ThisDrawing.Utility.GetPoint(, "請輸入拉泡泡起點 : ")
If Err Then Exit Sub ' 如果輸入錯誤就結束程式
p2 = ThisDrawing.Utility.GetPoint(p1, "請輸入拉泡泡終點 : ") ' 如果不想輸入, 按 Esc 離開程式.
If Err Then Exit Sub
Set line_obj = ThisDrawing.ModelSpace.AddLine(p1, p2) ' 畫線
Set cir_obj = ThisDrawing.ModelSpace.AddCircle(p2, 10) ' 畫圓
' intersect 是交叉的意思, 就是求交點. acExtendNone 是線跟圓都不要延伸, 所以有幾個變數可以讓你
' 選擇要不要延伸, 例如兩條線沒有交叉, 但如果你選擇 acExtendBoth, 那就可以求到交點.
int_p = line_obj.IntersectWith(cir_obj, acExtendNone)
line_obj.Delete ' 刪除原來跟圓交叉的舊直線
Set line_obj = ThisDrawing.ModelSpace.AddLine(p1, int_p) ' 畫新的直線剛好跟圓接合
End Sub
' Autocad 的 VBA help 其實就寫的很清楚, 範例也很多, 但都是英文的.
' 基本寫法跟 VB6 差不多, 所以可以參考 VB6 的書, 別人不要的 VB6 書本, 可以拿來看看.
Option Explicit ' 一定要定義變數
Public Sub bubble_line() ' bubble_line 程式名稱可以自己取
On Error Resume Next ' 如果有錯誤, 不管他
Dim line_obj As AcadLine ' 定義線的變數名稱
Dim cir_obj As AcadCircle ' 定義圓的變數名稱
Dim p1 As Variant ' 定義 拉泡泡起點的變數名稱
Dim p2 As Variant ' 定義 拉泡泡終點的變數名稱
Dim int_p As Variant ' 定義 拉泡泡直線跟泡泡交點的變數名稱
Dim bubble_number As Integer ' 定義泡泡號碼的名稱
Dim text_obj As AcadText ' 定義泡泡號碼寫入文字的變數名稱
' Thisdrawing 是現在這張圖紙的意思, Utility : VBA 輸入資料等都在這一類, 公用程式
p1 = ThisDrawing.Utility.GetPoint(, "請輸入拉泡泡起點 : ")
If Err Then Exit Sub ' 如果輸入錯誤就結束程式
p2 = ThisDrawing.Utility.GetPoint(p1, "請輸入拉泡泡終點 : ") ' 如果不想輸入, 按 Esc 離開程式.
If Err Then Exit Sub
Set line_obj = ThisDrawing.ModelSpace.AddLine(p1, p2) ' 畫線
Set cir_obj = ThisDrawing.ModelSpace.AddCircle(p2, 10) ' 畫圓
' intersect 是交叉的意思, 就是求交點. acExtendNone 是線跟圓都不要延伸, 所以有幾個變數可以讓你
' 選擇要不要延伸, 例如兩條線沒有交叉, 但如果你選擇 acExtendBoth, 那就可以求到交點.
int_p = line_obj.IntersectWith(cir_obj, acExtendNone)
line_obj.Delete ' 刪除原來跟圓交叉的舊直線
Set line_obj = ThisDrawing.ModelSpace.AddLine(p1, int_p) ' 畫新的直線剛好跟圓接合
End Sub
Tiger&蘋果爸 寫到: 謝謝熱心程式教學分享~< 積分 +1>
[公告]關於團隊成員的回文及貢獻
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
謝謝大家, 或許是因為我以前寫 Autolisp 算括號算的半死, 所以我覺得 VBA 比 lisp 簡單多了, 大家應該用 VBA. 但後來 Autodesk 不支援 VBA 改 VB.Net, 變的很麻煩, 讓我對 VBA 很失望, 不曉得 VBA 還有多少價值. 但昨天到 Autodesk discussion board 看到有人說 Autocad 2014 對 64 位元 VBA 好像有改善了, 讓我有點開心, 等我拿到 Autocad 2014 版本再來試試, 呵呵. 對有點英文跟電腦基礎的人, 程式設計裏面 VBA 算是最簡單的了, 以前學 Autolisp 還要買書, 從頭一點一滴學起. VBA 則是因為我在學校就學過 Basic, 英文也不太困難, 再看 on-line help 跟 Autodesk discussion 就學來了. 與大家共勉!!
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
' 發文這個外國人以前就寫了上千支的 VBA 程式, 後來因為 64位元作業系統, 以前 32 位元作業系統寫的 VBA 就會有問題, 所以他要一個一個慢慢的把 VBA 轉換到 VB.Net, 這樣很慢又很累. 現在 Autocad 2014 的 VBA 跑比前的程式好像變正常了, 所以 VBA 至少還可以再撐個幾年, 但最後的建議還是要轉到 VB.Net, 我也試了一陣子有點麻煩, 但基本 Basic 語法還是差不多, 希望 VBA 可以一直撐下去, VBA 很好用.
' 第一篇文章
VBA 7.1
Options
128 Views, 3 Replies
08-30-2013 04:57 PM
Wow, I just run some of my old code on a 64bit and it runs fast. We have been delaying our OS upgrade to 64 bit due to our VBA code running unacceptably slow.
I am glad that Autodesk has had a change of heart. Is anyone as excited as me.!!!! I have been coding in .NET for two years now and I just learned that AutoCAD 2014 has fixed the issue with VBA 64bit.
Do you think that now VBA runs on 64bit that they intend to keep the support for it?
' 第二篇文章
Thank you Alfred.
You have very valid points. Now I am queries as to how much recourse Autodesk is currently dedicating towards the .NET vs. VBA.
I currently have thousands of code in VBA and I have been slowly and painstakingly trying to convert them to .NET . I go very exited for VBA 7.1 news. But I think I will utilize VBA 7.1 for my old code and take your advice for all future code.
Thank you again Alfred
I ask because I prefer VBA IDE, but I have now dedicated couple of years programming in .NET . If VBA is staying I may switch back.
' 第一篇文章
VBA 7.1
Options
128 Views, 3 Replies
08-30-2013 04:57 PM
Wow, I just run some of my old code on a 64bit and it runs fast. We have been delaying our OS upgrade to 64 bit due to our VBA code running unacceptably slow.
I am glad that Autodesk has had a change of heart. Is anyone as excited as me.!!!! I have been coding in .NET for two years now and I just learned that AutoCAD 2014 has fixed the issue with VBA 64bit.
Do you think that now VBA runs on 64bit that they intend to keep the support for it?
' 第二篇文章
Thank you Alfred.
You have very valid points. Now I am queries as to how much recourse Autodesk is currently dedicating towards the .NET vs. VBA.
I currently have thousands of code in VBA and I have been slowly and painstakingly trying to convert them to .NET . I go very exited for VBA 7.1 news. But I think I will utilize VBA 7.1 for my old code and take your advice for all future code.
Thank you again Alfred
I ask because I prefer VBA IDE, but I have now dedicated couple of years programming in .NET . If VBA is staying I may switch back.
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
' ThisDrawing.Utility.AngleFromXAxis -----> 這個指令蠻實用的, 如果你需要兩個點的角度, 就可以用這個指令!! 但因為是弳度, 所以需要先除以 pi = 3.141592/180 得到"角度". 然後再用 round(角度, 1) 這個指令來取小數1位, 如果是 0, 就是取整數.
Sub Example_AngleFromXAxis()
' This example finds the angle, in radians, between the X axis
' and a line defined by two points.
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim retAngle As Double
pt1(0) = 2: pt1(1) = 5: pt1(2) = 0
pt2(0) = 5: pt2(1) = 2: pt2(2) = 0
' Return the angle
retAngle = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
' Create the line for a visual reference
Dim lineObj As AcadLine
Set lineObj = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
ZoomAll
' Display the angle found
MsgBox "The angle in radians between the X axis and the line is " & retAngle, , "AngleFromXAxis Example"
End Sub
Sub Example_AngleFromXAxis()
' This example finds the angle, in radians, between the X axis
' and a line defined by two points.
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim retAngle As Double
pt1(0) = 2: pt1(1) = 5: pt1(2) = 0
pt2(0) = 5: pt2(1) = 2: pt2(2) = 0
' Return the angle
retAngle = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
' Create the line for a visual reference
Dim lineObj As AcadLine
Set lineObj = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
ZoomAll
' Display the angle found
MsgBox "The angle in radians between the X axis and the line is " & retAngle, , "AngleFromXAxis Example"
End Sub
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
Public tm As AcadModelSpace ' 定義 tm, tu 為公共變數
Public tu As AcadUtility
Public Const pi = 3.141592 / 180 ' 直接用 pi 代表
Public ent_set As AcadSelectionSet ' 大部份程式都會用到物件選擇集
Option Explicit
Public Sub cir_size_sort() ' 圓半徑排大小
ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim cir_set As AcadSelectionSet
Dim i_count As Integer
Dim text_obj As AcadText
add_selection_process cir_set, "cir_set_name" ' 建立選擇集
Set cir_set = selection_onscreen_process(0, "CIRCLE") ' 在圖面上選取過濾圓
ReDim cir_array(cir_set.count - 1) As AcadCircle ' 建立一個剛好可以放進 cir_set 數量的圓的陣列
For i_count = 0 To UBound(cir_array) ' cir_set 裏面的圓一個一個放進陣列, 等著排大小
Set cir_array(i_count) = cir_set.Item(i_count)
Next i_count
array_sort_process cir_array ' 送進排大小副程式
For i_count = 0 To UBound(cir_array) ' 排好後用文字從大到小標示 1, 2, 3, 4................
Set text_obj = tm.AddText(i_count + 1, cir_array(i_count).Center, cir_array(i_count).Radius)
text_obj.color = 1: text_obj.Update
Next i_count
set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr
End Sub
' 陣列排序, 這就是在 Basic 課本上都會提到的 泡泡排序法(Bubble Sort)
' 所以在學校學過 Basic 的人應該都有印象.
Private Sub array_sort_process(entity_array() As AcadCircle) ' 如果是圖塊要排大小, 就要改 AcadBlockReference
Dim i_count, d_count As Integer
Dim ent_temp As AcadCircle ' 暫存的圓
Dim first_cir_radius As Double
Dim second_cir_radius As Double
For i_count = LBound(entity_array) To UBound(entity_array) - 1 ' 注意是 i_count 跟 d_count
For d_count = i_count + 1 To UBound(entity_array) ' 如果要改程式, 要注意 i_count, d_count
first_cir_radius = entity_array(i_count).Radius
second_cir_radius = entity_array(d_count).Radius
If second_cir_radius > first_cir_radius Then
Set ent_temp = entity_array(i_count) ' 這三行程式就是把圓交換在陣列的位置
Set entity_array(i_count) = entity_array(d_count)
Set entity_array(d_count) = ent_temp
End If ' val
Next d_count
Next i_count
Set ent_temp = Nothing
End Sub
' 加入選擇集函式
Private Sub add_selection_process(sset_obj, sset_name As String)
Dim icount As Integer
icount = ThisDrawing.SelectionSets.count
While (icount > 0)
If ThisDrawing.SelectionSets.Item(icount - 1).Name = sset_name Then
ThisDrawing.SelectionSets.Item(icount - 1).Delete
End If
icount = icount - 1
Wend
Set sset_obj = ThisDrawing.SelectionSets.Add(sset_name)
End Sub
' 在營幕上選取物件加入選擇集
Private Function selection_onscreen_process _
(ByVal g_data As Integer, ByVal d_data As String) As AcadSelectionSet
Dim sset_name As String
sset_name = "onscreen_sset"
Dim icount As Integer
icount = ThisDrawing.SelectionSets.count
While (icount > 0)
If ThisDrawing.SelectionSets.Item(icount - 1).Name = sset_name Then
ThisDrawing.SelectionSets.Item(icount - 1).Delete
End If
icount = icount - 1
Wend
Dim sset_obj As AcadSelectionSet
Set sset_obj = ThisDrawing.SelectionSets.Add(sset_name)
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant, datacode As Variant
gpCode(0) = g_data
dataValue(0) = d_data
groupCode = gpCode
datacode = dataValue
sset_obj.SelectOnScreen groupCode, datacode
Set selection_onscreen_process = sset_obj
End Function
Private Sub set_nothing_process()
Set tm = Nothing: Set tu = Nothing: Set ent_set = Nothing
End Sub
Public tu As AcadUtility
Public Const pi = 3.141592 / 180 ' 直接用 pi 代表
Public ent_set As AcadSelectionSet ' 大部份程式都會用到物件選擇集
Option Explicit
Public Sub cir_size_sort() ' 圓半徑排大小
ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim cir_set As AcadSelectionSet
Dim i_count As Integer
Dim text_obj As AcadText
add_selection_process cir_set, "cir_set_name" ' 建立選擇集
Set cir_set = selection_onscreen_process(0, "CIRCLE") ' 在圖面上選取過濾圓
ReDim cir_array(cir_set.count - 1) As AcadCircle ' 建立一個剛好可以放進 cir_set 數量的圓的陣列
For i_count = 0 To UBound(cir_array) ' cir_set 裏面的圓一個一個放進陣列, 等著排大小
Set cir_array(i_count) = cir_set.Item(i_count)
Next i_count
array_sort_process cir_array ' 送進排大小副程式
For i_count = 0 To UBound(cir_array) ' 排好後用文字從大到小標示 1, 2, 3, 4................
Set text_obj = tm.AddText(i_count + 1, cir_array(i_count).Center, cir_array(i_count).Radius)
text_obj.color = 1: text_obj.Update
Next i_count
set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr
End Sub
' 陣列排序, 這就是在 Basic 課本上都會提到的 泡泡排序法(Bubble Sort)
' 所以在學校學過 Basic 的人應該都有印象.
Private Sub array_sort_process(entity_array() As AcadCircle) ' 如果是圖塊要排大小, 就要改 AcadBlockReference
Dim i_count, d_count As Integer
Dim ent_temp As AcadCircle ' 暫存的圓
Dim first_cir_radius As Double
Dim second_cir_radius As Double
For i_count = LBound(entity_array) To UBound(entity_array) - 1 ' 注意是 i_count 跟 d_count
For d_count = i_count + 1 To UBound(entity_array) ' 如果要改程式, 要注意 i_count, d_count
first_cir_radius = entity_array(i_count).Radius
second_cir_radius = entity_array(d_count).Radius
If second_cir_radius > first_cir_radius Then
Set ent_temp = entity_array(i_count) ' 這三行程式就是把圓交換在陣列的位置
Set entity_array(i_count) = entity_array(d_count)
Set entity_array(d_count) = ent_temp
End If ' val
Next d_count
Next i_count
Set ent_temp = Nothing
End Sub
' 加入選擇集函式
Private Sub add_selection_process(sset_obj, sset_name As String)
Dim icount As Integer
icount = ThisDrawing.SelectionSets.count
While (icount > 0)
If ThisDrawing.SelectionSets.Item(icount - 1).Name = sset_name Then
ThisDrawing.SelectionSets.Item(icount - 1).Delete
End If
icount = icount - 1
Wend
Set sset_obj = ThisDrawing.SelectionSets.Add(sset_name)
End Sub
' 在營幕上選取物件加入選擇集
Private Function selection_onscreen_process _
(ByVal g_data As Integer, ByVal d_data As String) As AcadSelectionSet
Dim sset_name As String
sset_name = "onscreen_sset"
Dim icount As Integer
icount = ThisDrawing.SelectionSets.count
While (icount > 0)
If ThisDrawing.SelectionSets.Item(icount - 1).Name = sset_name Then
ThisDrawing.SelectionSets.Item(icount - 1).Delete
End If
icount = icount - 1
Wend
Dim sset_obj As AcadSelectionSet
Set sset_obj = ThisDrawing.SelectionSets.Add(sset_name)
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant, datacode As Variant
gpCode(0) = g_data
dataValue(0) = d_data
groupCode = gpCode
datacode = dataValue
sset_obj.SelectOnScreen groupCode, datacode
Set selection_onscreen_process = sset_obj
End Function
Private Sub set_nothing_process()
Set tm = Nothing: Set tu = Nothing: Set ent_set = Nothing
End Sub
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
剛剛測試完 Autocad 2014 位元跟 Window 7 版本 64 位元來執行以前 32 位元寫的 VBA 程式. 原來會變的很慢很慢的情形, 真的變快了, 雖然好像沒有在 32 位元的快, 但看起來是可以接受, 真是可喜可賀!! 哈!!
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
' Autocad 2014 裏面的 VBA 7.1 說明, 以前是 VBA 6.0 所以才會有問題!!
( 64 位元 Visual Basic for Applications 概觀
VBA 包含語言功能,可讓 VBA 程式碼在 32 位元及 64 位元環境中正確地執行。
如果使用 VBA 版本 6 (含) 以前版本所撰寫的 VBA 程式碼未修改成可在 64 位元版本的應用程式中執行,在 64 位元平台執行時可能會產生錯誤。 之所以會產生錯誤,是因為 VBA 版本 6 (含) 以前版本隱含以 32 位元平台為目標,並且通常包含使用 32 位元資料型別做為指標和控制代碼以呼叫 Windows 應用程式開發介面的 Declare 陳述式。 因為 VBA 版本 6 (含) 以前版本沒有特定的資料型別做為指標或控制代碼,所以會使用 Long 資料型別 (此為 32 位元 4 位元組的資料型別) 來參考指標和控制代碼。 64 位元環境中的指標和控制代碼是 8 位元組 64 位元數量。 這些 64 位元數量無法以 32 位元資料型別保留。
注意 如果 VBA 程式碼在 64 位元版本的應用程式中執行,則只需修改 VBA 程式碼。 )
( 64 位元 Visual Basic for Applications 概觀
VBA 包含語言功能,可讓 VBA 程式碼在 32 位元及 64 位元環境中正確地執行。
如果使用 VBA 版本 6 (含) 以前版本所撰寫的 VBA 程式碼未修改成可在 64 位元版本的應用程式中執行,在 64 位元平台執行時可能會產生錯誤。 之所以會產生錯誤,是因為 VBA 版本 6 (含) 以前版本隱含以 32 位元平台為目標,並且通常包含使用 32 位元資料型別做為指標和控制代碼以呼叫 Windows 應用程式開發介面的 Declare 陳述式。 因為 VBA 版本 6 (含) 以前版本沒有特定的資料型別做為指標或控制代碼,所以會使用 Long 資料型別 (此為 32 位元 4 位元組的資料型別) 來參考指標和控制代碼。 64 位元環境中的指標和控制代碼是 8 位元組 64 位元數量。 這些 64 位元數量無法以 32 位元資料型別保留。
注意 如果 VBA 程式碼在 64 位元版本的應用程式中執行,則只需修改 VBA 程式碼。 )
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
產生自訂的 VBA 工具列跟按鈕, 點擊就執行 VBA 程式.
1. 可以把程式放進"載入應用程式", 這樣每次開啟軟體就會自動載入這個程式 alternate_fillet.
2. 在"自定工具"可以產生新的工具列, 例如叫"VBA"用來製作按鈕點擊就可以叫 VBA 程式.
3. 在 VBA 工具列應該可以隨便拉一個指令來製作按鈕.
4. 再把按鈕裏面的指令改成 ^C^C (command "vbarun" "alternate_fillet")
5. 這樣點擊這個按鈕應該就可以執行程式.
6. Thanks.
1. 可以把程式放進"載入應用程式", 這樣每次開啟軟體就會自動載入這個程式 alternate_fillet.
2. 在"自定工具"可以產生新的工具列, 例如叫"VBA"用來製作按鈕點擊就可以叫 VBA 程式.
3. 在 VBA 工具列應該可以隨便拉一個指令來製作按鈕.
4. 再把按鈕裏面的指令改成 ^C^C (command "vbarun" "alternate_fillet")
5. 這樣點擊這個按鈕應該就可以執行程式.
6. Thanks.
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
' ****** 倒圓角(fillet)時不輸入 R, 直接輸入半徑數字就開始.
Public tm As AcadModelSpace ' 定義 tm, tu 為公共變數
Public tu As AcadUtility
Public Const pi = 3.141592 / 180 ' 直接用 pi 代表
Public ent_set As AcadSelectionSet ' 大部份程式都會用到物件選擇集
Option Explicit
Public Sub alternate_fillet()
'ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr ' 設 undo, be, e 可以快速恢復圖面原狀
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr ' 設為世界座標
On Error Resume Next
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim fillet_radius As Integer
Dim first_obj As AcadObject
Dim second_obj As AcadObject
Dim pick_p As Variant
Dim inputString As String
fillet_radius = 10
Do While True
Err.Clear
fillet_radius = tu.GetReal("請輸入半徑 : " & " (預設半徑_確定(Enter) = " & _
fillet_radius & " / 請輸入 0 結束程式) : ................")
If Err Then
If InStr(Err.Description, "使用者輸入") <> 0 Then Err.Clear
End If
If fillet_radius = 0 Then Exit Do
tu.GetEntity first_obj, pick_p, "請選擇第一個物件!!........."
If Err Then GoTo one_more_time
tu.GetEntity second_obj, pick_p, "請選取第二個物件!!........."
If Err Then GoTo one_more_time
ThisDrawing.SendCommand "fillet" & vbCr & "r" & vbCr & Trim(Str(fillet_radius)) & vbCr & _
handle_ent_obj(first_obj) & vbCr & handle_ent_obj(second_obj) & vbCr
one_more_time:
Loop
'ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr
End Sub
Private Function handle_ent_obj(entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
handle_ent_obj = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
Public tm As AcadModelSpace ' 定義 tm, tu 為公共變數
Public tu As AcadUtility
Public Const pi = 3.141592 / 180 ' 直接用 pi 代表
Public ent_set As AcadSelectionSet ' 大部份程式都會用到物件選擇集
Option Explicit
Public Sub alternate_fillet()
'ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr ' 設 undo, be, e 可以快速恢復圖面原狀
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr ' 設為世界座標
On Error Resume Next
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim fillet_radius As Integer
Dim first_obj As AcadObject
Dim second_obj As AcadObject
Dim pick_p As Variant
Dim inputString As String
fillet_radius = 10
Do While True
Err.Clear
fillet_radius = tu.GetReal("請輸入半徑 : " & " (預設半徑_確定(Enter) = " & _
fillet_radius & " / 請輸入 0 結束程式) : ................")
If Err Then
If InStr(Err.Description, "使用者輸入") <> 0 Then Err.Clear
End If
If fillet_radius = 0 Then Exit Do
tu.GetEntity first_obj, pick_p, "請選擇第一個物件!!........."
If Err Then GoTo one_more_time
tu.GetEntity second_obj, pick_p, "請選取第二個物件!!........."
If Err Then GoTo one_more_time
ThisDrawing.SendCommand "fillet" & vbCr & "r" & vbCr & Trim(Str(fillet_radius)) & vbCr & _
handle_ent_obj(first_obj) & vbCr & handle_ent_obj(second_obj) & vbCr
one_more_time:
Loop
'ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr
End Sub
Private Function handle_ent_obj(entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
handle_ent_obj = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
回復: [教學]VBA 基本程式 拉泡泡 001
' 這是中望 ZWcad 的版本, 如果要 Autocad 版本就是把 Zcad 全改成 Acad 就可以了!! 參考一下!!
Public tm As ZcadModelSpace
Public tu As ZcadUtility
Option Explicit
Public Sub alternate_fillet()
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr ' 設為世界座標
On Error Resume Next
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim radius_str As String
Dim fillet_radius As Integer
Dim first_obj As ZcadObject
Dim second_obj As ZcadObject
Dim pick_p As Variant
Dim inputString As String
Dim line_obj As ZcadLine
Dim second_radius_str As String
Do While True
Err.Clear
radius_str = tu.GetString(False, "請輸入半徑或 [聚合線(P), 結束(0) : ")
radius_str = UCase(Trim(radius_str))
If radius_str = "P" Then
second_radius_str = tu.GetString(False, "請輸入聚合線倒圓角的半徑 [結束(0)]")
fillet_radius = second_radius_str
Else
fillet_radius = radius_str
End If
If fillet_radius = 0 Then Exit Do
tu.GetEntity first_obj, pick_p, "請選擇第一個物件!!........."
If Err Then GoTo one_more_time
first_obj.Highlight True
If radius_str <> "P" Then
tu.GetEntity second_obj, pick_p, "請選取第二個物件!!........."
If Err Then GoTo one_more_time
second_obj.Highlight True
End If
If radius_str = "P" Then
ThisDrawing.SendCommand "fillet" & vbCr & "p" & vbCr & handle_ent_obj(first_obj) & vbCr
Else
ThisDrawing.SendCommand "fillet" & vbCr & "r" & vbCr & Trim(Str(fillet_radius)) & vbCr & _
handle_ent_obj(first_obj) & vbCr & handle_ent_obj(second_obj) & vbCr
End If
one_more_time:
Loop
first_obj.Highlight False: second_obj.Highlight False
End Sub
Private Function handle_ent_obj(entObj As ZcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
handle_ent_obj = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
Public tm As ZcadModelSpace
Public tu As ZcadUtility
Option Explicit
Public Sub alternate_fillet()
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr ' 設為世界座標
On Error Resume Next
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim radius_str As String
Dim fillet_radius As Integer
Dim first_obj As ZcadObject
Dim second_obj As ZcadObject
Dim pick_p As Variant
Dim inputString As String
Dim line_obj As ZcadLine
Dim second_radius_str As String
Do While True
Err.Clear
radius_str = tu.GetString(False, "請輸入半徑或 [聚合線(P), 結束(0) : ")
radius_str = UCase(Trim(radius_str))
If radius_str = "P" Then
second_radius_str = tu.GetString(False, "請輸入聚合線倒圓角的半徑 [結束(0)]")
fillet_radius = second_radius_str
Else
fillet_radius = radius_str
End If
If fillet_radius = 0 Then Exit Do
tu.GetEntity first_obj, pick_p, "請選擇第一個物件!!........."
If Err Then GoTo one_more_time
first_obj.Highlight True
If radius_str <> "P" Then
tu.GetEntity second_obj, pick_p, "請選取第二個物件!!........."
If Err Then GoTo one_more_time
second_obj.Highlight True
End If
If radius_str = "P" Then
ThisDrawing.SendCommand "fillet" & vbCr & "p" & vbCr & handle_ent_obj(first_obj) & vbCr
Else
ThisDrawing.SendCommand "fillet" & vbCr & "r" & vbCr & Trim(Str(fillet_radius)) & vbCr & _
handle_ent_obj(first_obj) & vbCr & handle_ent_obj(second_obj) & vbCr
End If
one_more_time:
Loop
first_obj.Highlight False: second_obj.Highlight False
End Sub
Private Function handle_ent_obj(entObj As ZcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
handle_ent_obj = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
shackle_2005- 初級會員
- 文章總數 : 232
年齡 : 53
來自 : 台中
職業 : 程式設計
愛好 : 音樂
個性 : 隨和
使用年資 : 10 年
使用版本 : 2013
積分 : 3
經驗值 : 6715
威望值 : 361
注冊日期 : 2010-09-19
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第2頁(共2頁)
這個論壇的權限:
您 無法 在這個版面回復文章