[教學]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

---

Tiger&蘋果爸 寫到: 謝謝熱心程式教學分享~< 積分 +1>
[公告]關於團隊成員的回文及貢獻

謝謝大家, 或許是因為我以前寫 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 就學來了. 與大家共勉!!

' 發文這個外國人以前就寫了上千支的 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.

' 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

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

剛剛測試完 Autocad 2014 位元跟 Window 7 版本 64 位元來執行以前 32 位元寫的 VBA 程式. 原來會變的很慢很慢的情形, 真的變快了, 雖然好像沒有在 32 位元的快, 但看起來是可以接受, 真是可喜可賀!! 哈!!

' 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 程式碼。 )

產生自訂的 VBA 工具列跟按鈕, 點擊就執行 VBA 程式.

1. 可以把程式放進"載入應用程式", 這樣每次開啟軟體就會自動載入這個程式 alternate_fillet.

2. 在"自定工具"可以產生新的工具列, 例如叫"VBA"用來製作按鈕點擊就可以叫 VBA 程式.

3. 在 VBA 工具列應該可以隨便拉一個指令來製作按鈕.

4. 再把按鈕裏面的指令改成 ^C^C (command "vbarun" "alternate_fillet")

5. 這樣點擊這個按鈕應該就可以執行程式.

6. Thanks.

' ****** 倒圓角(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

' 這是中望 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