[教學]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>
[公告]關於團隊成員的回文及貢獻

很不錯的範例,註解的也很詳細,非常適合新手拿來觀摩!

' ******************************************************
' 第一章 樣本程式認識 / tm, tu 使用介紹                
'
' ******************************************************
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 test()

' sendcommand 在 Autocad 命令列下直接下指令
ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr ' 設 undo, be, e 可以快速恢復圖面原狀
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr ' 設為世界座標

' 設定 tm 為這張圖面的模型空間, 設定 tu 為這張圖面的公用程式 _
 上一行的最後面, "_" 符號, 可用來連結兩行程式, 或文字. _
 , 而下一行中的 ":" 符號, 可用來連結兩行不同的程式, 減少行數
 
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

MsgBox tm.count ' 顯示圖面上所以物件的總數, 這樣就可以取代 Thisdrawing.Modelspace 省打字又省空間

ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

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 test()

ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr

' 設定 tm 為這張圖面的模型空間, 設定 tu 為這張圖面的公用程式
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

' ************
' 變數定義   *
' ************

' 畫線變數定義 **************************************************
Dim line_obj As AcadLine ' 定義 line_obj 為一個線的物件
Dim start_p(0 To 2) As Double ' 定義起點及終點的座標
Dim end_p(0 To 2) As Double

' 畫圓變數定義 **************************************************
Dim circle_obj As AcadCircle ' 定義 circle_obj 為一個圓的物件
Dim circle_center(0 To 2) As Double ' 定義中心點的座標
Dim circle_radius As Double ' 定義圓的半徑

' 畫弧變數定義 **************************************************
Dim arc_obj As AcadArc ' 定義 arc_obj 為一個弧的物件

' 定義起點及終點的 "弳度", 即 = "角度" * pi
Dim start_angle, end_angle As Double
Dim arc_center(0 To 2) As Double ' 定義弧的中心點座標
Dim arc_radius As Double ' 定義弧的半徑

' ************
' 畫線工作   *
' ************

' 要從 5,5,0 到 10,10,0 畫一條線
start_p(0) = 5: start_p(1) = 5: start_p(2) = 0
end_p(0) = 10: end_p(1) = 10: end_p(2) = 0

' 在模型空間上執行畫線的動作
Set line_obj = tm.AddLine(start_p, end_p) ' 記得起頭是 Set .....

' 畫圓工作 **************************************************** _
 以 5,5,0 為中心畫一個半徑為 10 的圓
circle_center(0) = 5: circle_center(1) = 5: circle_center(2) = 0
circle_radius = 10

' 在模型空間上執行畫圓的動作
Set circle_obj = tm.AddCircle(circle_center, circle_radius)

' 畫弧工作 **************************************************** _
 以 30,10,0 為中心畫一個半徑 10, 起點 90 度到 終點 180 度的弧
arc_center(0) = 30: arc_center(1) = 10: arc_center(2) = 0
arc_radius = 10
start_angle = 90 * pi: end_angle = 180 * pi ' 轉換為 "弳度"

' 在模型空間上執行畫弧的動作
Set arc_obj = tm.AddArc(arc_center, arc_radius, start_angle, end_angle)
                                         
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

受教了....這樣的範例真的對我們新手幫助很大。

IntersectWith 好像是可以求交點的 ...有這方面的範例可以學習嗎

如果我有一條線, 可以求到該線段跟圖面上的那些線段有相交嗎0.0? 我想要求相交點的數量..

Dim first_obj As AcadEntity
Dim second_obj As AcadEntity
Dim pick_p As Variant ' 選取物件時, 下點的座標
Dim int_p As Variant

' 請先畫一個圓, 再畫一條線通過圓, 得到兩個交叉點
tu.GetEntity first_obj, pick_p, "請選取第一個物件! "
tu.GetEntity second_obj, pick_p, "請選取第二個物件! "

int_p = first_obj.IntersectWith(second_obj, acExtendNone)

' 交叉點 int_p 是一個 variant, 所以如果只有一個交點就會用 int_p(0) 記錄 X 座標值, int_p(1)
' 記錄 Y 座標值, int_p(2) 記錄 Z 座標值. 所以你用 Ubound(int_p) 這個函數就是顯示 2, 就是 012 的 2
' 如果是有兩個交點, int_p(3) 就會記錄第二點的 X 座標值, Ubound(int_p) 就會顯示 5 , 依此類推............

MsgBox UBound(int_p) ' 2

' ******************************************************
' *
' 第三章 tu.polarpoint / 給起點, 角度, 距離 *
' 得到另一點的座標 *
' *
' ******************************************************

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 test()

ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr

' 設定 tm 為這張圖面的模型空間, 設定 tu 為這張圖面的公用程式
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

Dim line_obj As AcadLine ' 線定義
Dim circle_obj As AcadCircle ' 圓定義

' 由座標 5,5,0 的起點 p1 處, 求 45 度, 距離 10 外的 p2 點座標
Dim p1(0 To 2) As Double ' 自行定義三點座標的點定義法
Dim p2 As Variant ' variant 為不自行定義, 要由 polar 來求點的點定義法

p1(0) = 5: p1(1) = 5: p1(2) = 0 ' 三點座標定義

p2 = tu.PolarPoint(p1, 45 * pi, 10) ' 給起點, 角度, 距離

Set line_obj = tm.AddLine(p1, p2) ' 求出 p2 座標, 即可用來畫線
Set circle_obj = tm.AddCircle(p2, 10) ' 也可在 p2 上畫圓

' 下一行中的 ":" 符號, 可用來連結兩行不同的程式, 以減少行數
Set line_obj = Nothing: Set circle_obj = Nothing

set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

' 隨著程式慢慢變長變複雜, codes 也會愈來愈多, 所以就要想辦法用副程式(sub)
' 要用的時候 call 就好, 讓主程式比較簡短(concise), 有效率.
' 我使用選擇集完並不會刪除, 所以圖面上的選擇集並不會自動不見.
' 所以要再用的時候我會 call 副程式, 把剛剛用過的刪除. 不然程式不能執行, 會有錯誤.
' 其它的運用也是一樣, 要多運用副程式, 不然中大型的程式會變的很冗長!!

public sub add_selection()

        Dim sset As AcadSelectionSet
        Dim sset_second as AcadSelectionSet
        Dim sset_third as AcadSelectionSet

        add_selection_process sset, "sset_name" ' 選擇集名稱隨便打, 如果需要第二個, 第三個選擇集, 則如下
        add_selection_process sset_second, "sset_second_name"
        add_selection_process sset_third, "sset_third_name"

        sset.Select acSelectionSetAll

        MsgBox sset.count

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

' 設定 tm 為這張圖面的模型空間, 設定 tu 為這張圖面的公用程式
Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility
Dim line_obj As AcadLine ' 線定義
Dim circle_obj As AcadCircle ' 圓定義

前面的例子是 ModelSpace
請問如果 印圖的配置空間呢?
我有2個配置空間 "配置" , "配置1"
是用PaperSpace  嗎?  怎麼指定是那一個配置空間?

set tp = Thisdrawing.Paperspace 試看看, Modelspace 以外我很少用.

VBA basic 005 ............... VBA 有一個特殊現象, 就是定義變數的時候有一點問題. Dim aa, bb, cc, dd as Double. 一般會把很多個變數排一起可以省空間. 定義 Double, Integer, String..... 等是 OK 的. 但如果是 Dim p1, p2, p3 as Variant. 或是 Dim p1 as Variant: Dim p2 as Variant. 用冒號把兩個接成一行, 這樣在下面程式執行的時候常常會出問題. 所以定義 Variant 的時後, 最後是 Dim p1 as Variant. 換下一行 Dim p2 as Variant. 如果有人知道為什麼也可以分享一下. Thanks.

' 看到大家在討論處理 dwg 的問題, 想說如果把實線切成 100 段小線段, 這樣會不會有幫助, 參考一下
'

Public tm As AcadModelSpace ' 定義 tm, tu 為公共變數
Public tu As AcadUtility
Public Const pi = 3.141592 / 180 ' 直接用 pi 代表
Public ent_set As AcadSelectionSet ' 大部份程式都會用到物件選擇集

Option Explicit

' 打圖面上所有實線都切成 100 段, 破壞圖面, 但看起來一樣
Public Sub line_cut()

ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr

Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

Dim ent_obj As AcadObject
Dim line_obj As AcadLine
Dim start_p As Variant
Dim end_p As Variant
Dim new_line As AcadLine
Dim second_p As Variant
Dim dis As Double
Dim angle_line As Double
Dim i_count As Integer
Dim layer_obj As AcadLayer

For Each ent_obj In tm ' 懶的用選擇集, 直接從圖面過濾線段

   If TypeOf ent_obj Is AcadLine Then ' Typeof 很好用, 過濾圖元類型
   
      Set line_obj = ent_obj ' 找到線元件, 轉換設為 Acadline
     
      Set layer_obj = ThisDrawing.Layers.Item(line_obj.Layer) ' 找線段的圖層
             
      If layer_obj.Linetype = "CONTINUOUS" Then ' 看線段是不是實線 ??
     
         start_p = line_obj.StartPoint: end_p = line_obj.EndPoint ' 抓起點終點
     
         dis = line_obj.Length / 100: angle_line = line_obj.angle ' 取 1/100 的距離及角度
         
         For i_count = 1 To 100 ' 開始畫 100 段小線條
             second_p = tu.PolarPoint(start_p, angle_line, dis)
             Set new_line = tm.AddLine(start_p, second_p)
             new_line.Layer = line_obj.Layer: new_line.color = line_obj.color: new_line.Update
             
             start_p = second_p ' 取剛畫好小線段的終點當新線段的起點
         Next i_count
         line_obj.Delete
         
      End If
   End If
Next ent_obj

set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

Private Sub set_nothing_process()
Set tm = Nothing: Set tu = Nothing: Set ent_set = Nothing
End Sub

TypeOf 沒這樣用過,謝謝前輩分享,又會了一招!

' 寫完程式, 執行計算完大多會開始繪圖或製做表格. 所以一堆線條圖案畫完就需要做成一個完整的圖塊, 方便移動刪除. 但不需要很正式的名稱, 所以就可以用到程式設計的 function 功 能. Dim block_name as string
block_name = rnd_process
這樣寫就可以得到一個很多個數字的字串, 因為是亂數處理, 所以不太容易會重覆.
function 功能跟 sub 不一樣, 像 rnd_process 就好像是一個字串變數可以隨意使用.

' 產生亂數
Public Function rnd_process() As String

' 建新圖塊 ***************************
Randomize   ' 對亂數產生器做初始化的動作。
rnd_process = Trim(Str(Int((9 * 10 ^ 14 * Rnd) + 10 ^ 14)))

End Function

十分感謝樓主的熱心大絕分享!!
這個主題一定要推一下的阿，對有心學習VBA的朋友們幫助實在很大:)

我的第一個有 userform 的 VBA 程式, 上傳圖片測試

VBA 很重要的一部份就是 選單的製作, 以前我們公司的 Autolisp 開發者就是因為 DCL 選單開發太麻煩才停止, 改用 VBA, 現在有沒有比較方便我不知道. 但 VBA 真的很簡單, 隨便翻翻以前舊的 VB6 書籍就可以學會. 先提最重要的一點就是 Optionbutton 跟 Frame, 初學者一開始不容易懂. Optionbutton 一般就是用在多選一功能(唯一單選), 但重點就是製做完多選的按紐, 記得要全部放進 frame 的框框裏面, 這樣才可以"唯一單選", 這很重要, 其它的功能選項我想你試試就會懂, 希望這個可以幫初學者省點時間, 3QVM........

VBA 小技巧, 如果對一個 VBA 的指令不熟悉, 想看 Auotcad 的 on-line help. 可以將游標移到這個英文字的裏面, 然後按 F1 鍵, 就會自動出現這個指令的英文說明. 例如 Thisdrawing.Modelspace 把滑鼠游標移到 Modelspace 裏面, 按 F1 鍵, 就會出現 Modelspace 的說明, Thanks

' Autocad 內建範例, 如何產生 2D 聚合線介紹

Sub Example_AddLightWeightPolyline()
' This example creates a lightweight polyline in model space.

Dim plineObj As AcadLWPolyline ' 名稱可以自己取
Dim points(0 To 9) As Double ' 0, 1 代表第一點的 x, y 座標. 依此類推

' Define the 2D polyline points 定義 2D 點的座標
points(0) = 1: points(1) = 1 ' 第一點 x, y 座標
points(2) = 1: points(3) = 2 ' 第二點 x, y 座標
points(4) = 2: points(5) = 2
points(6) = 3: points(7) = 2
points(8) = 4: points(9) = 4

' Create a lightweight Polyline object in model space
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
ZoomAll

End Sub

看到大家在討論 measure , 所以我也來湊湊熱鬧, 我寫的這個是可以在選單上使用按鍵來直接改變圖塊間距的大小, 就可以在圖面上看到圖塊的分佈變的緊一點或鬆一點. 如果大家有興趣我可以提供檔案, 但我不知道怎麼上傳, 謝謝. new_measure module 部份的程式碼
' *************************************************
Public tm As AcadModelSpace ' 定義 tm, tu 為公共變數
Public tu As AcadUtility

' 要 measure 的物件(全區域變數, 所以程式都可以讀的到)
Public ent_obj As AcadObject
Public blkref_obj As AcadBlockReference ' 圖塊

Option Explicit

Public Sub new_measure()

On Error Resume Next

ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr

Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

Dim pick_p As Variant

tu.GetEntity ent_obj, pick_p, "請選取要 measure 的物件 ! ....."

If Err Then Exit Sub

tu.GetEntity blkref_obj, pick_p, "請選取圖塊 !! ....... "

If Err Then Exit Sub

UserForm1.Show

set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

Private Sub set_nothing_process()
Set tm = Nothing: Set tu = Nothing: Set ent_set = Nothing
End Sub

' **********************************************************************
' form 的程式碼
' **********************************************************************
Public new_blkref As AcadBlockReference ' meausre 好的所有物件做成圖塊

Option Explicit

Private Sub CommandButton1_Click()

On Error Resume Next

UserForm1.Hide

new_blkref.Delete

TextBox1 = Val(TextBox1) - Val(TextBox2) ' 圖塊間距大一點

make_new_blkref ' 產生新圖塊

UserForm1.Show

End Sub

Private Sub CommandButton2_Click()

On Error Resume Next

UserForm1.Hide

new_blkref.Delete

TextBox1 = Val(TextBox1) + Val(TextBox2) ' 圖塊間距小一點

make_new_blkref

UserForm1.Show

End Sub

Private Sub CommandButton3_Click()
End
End Sub

Private Sub userform_initialize()

On Error Resume Next

TextBox1 = 100 ' 預設的數字
TextBox2 = 5

make_new_blkref

End Sub

Private Sub make_new_blkref()

On Error Resume Next

Dim block_name As String
Dim origin(0 To 2) As Double

block_name = rnd_process ' 產生薍數圖塊名稱

' 使用 measure 指令產生圖塊
ThisDrawing.SendCommand "measure" & vbCr & new_ent_obj(ent_obj) & _
       vbCr & "b" & vbCr & blkref_obj.Name & vbCr & vbCr & _
                                                Val(TextBox1) & vbCr
                         
' 使用 "p" (previous) 指令可以將剛產生的圖變做成一個圖塊
ThisDrawing.SendCommand "-block" & vbCr & block_name & _
                            vbCr & "0,0,0" & vbCr & "p" & vbCr & vbCr

' 插入做好的圖塊
Set new_blkref = tm.InsertBlock(origin, block_name, 1, 1, 1, 0)
new_blkref.Update

End Sub

' 產生亂數
Private Function rnd_process() As String

' 建新圖塊 ***************************
Randomize   ' 對亂數產生器做初始化的動作。
rnd_process = Trim(Str(Int((9 * 10 ^ 14 * Rnd) + 10 ^ 14)))

End Function

' 這個功能可以讓 VBA sendcommand 指令像 lisp 一樣可以吃 物件如 Acadobject
Public Function new_ent_obj(entObj As AcadEntity) As String
'Designed to work with SendCommand, which can't pass objects.
'This gets an objects handle and converts it to a string
'of lisp commands that returns an entity name when run in SendCommand.
Dim entHandle As String
entHandle = entObj.Handle
new_ent_obj = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function

' 在 2D 討論區有一個複線想要直接算出總長度的 case, 我試了一下, 下面的 codes 可能可以, 大家參考一下.

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 mline_length()

On Error Resume Next

ThisDrawing.SendCommand "undo" & vbCr & "be" & vbCr
ThisDrawing.SendCommand "ucs" & vbCr & "w" & vbCr

Set tm = ThisDrawing.ModelSpace: Set tu = ThisDrawing.Utility

Dim mline As AcadMLine
Dim mline_copy As AcadMLine
Dim exp As Variant
Dim line_obj As AcadLine
Dim pline As AcadPolyline
Dim block_name As String
Dim blkref_obj As AcadBlockReference
Dim origin_p(0 To 2) As Double
Dim pick_p As Variant

block_name = rnd_process

tu.GetEntity mline, pick_p, "請選取複線 ! ....... "

If Err Then Exit Sub

Set mline_copy = mline.Copy ' copy 一份當做 last 物件, 才可以用 explode 炸開

' 因為複線 mline 在 VBA 好像沒有 explode 這個功能, 所以用 sendcommand
ThisDrawing.SendCommand "explode" & vbCr & "l" & vbCr & vbCr

' 把前面炸開的所有線段做成一個圖塊
ThisDrawing.SendCommand "-block" & vbCr & block_name & _
                                                 vbCr & "0,0,0" & vbCr & "p" & vbCr & vbCr

' 插入做好的圖塊
Set blkref_obj = tm.InsertBlock(origin_p, block_name, 1, 1, 1, 0): blkref_obj.Update

' 再把圖塊炸開, 原來的圖塊刪除
exp = blkref_obj.Explode: blkref_obj.Delete

Dim i_count As Integer
Dim total_length As Double

' 然後把所以線段的長度一個一個加總, 然後刪除
For i_count = 0 To UBound(exp)
   Set line_obj = exp(i_count): line_obj.color = 3: line_obj.Update
   
   total_length = total_length + line_obj.Length
   line_obj.Delete
Next i_count

Dim text_obj As AcadText
Dim insert_p As Variant

insert_p = tu.GetPoint(, "請點選總長度插入點!! .........")

If Err Then Exit Sub

' 把得到的總長度做成文字插入圖面, 這樣比較方便, OK
Set text_obj = tm.AddText(Int(total_length), insert_p, Int(total_length / 100))

set_nothing_process ' 記憶體釋放
ThisDrawing.SendCommand "undo" & vbCr & "e" & vbCr

End Sub

' 產生亂數
Private Function rnd_process() As String

' 建新圖塊 ***************************
Randomize   ' 對亂數產生器做初始化的動作。
rnd_process = Trim(Str(Int((9 * 10 ^ 14 * Rnd) + 10 ^ 14)))

End Function

Private Sub set_nothing_process()
Set tm = Nothing: Set tu = Nothing: Set ent_set = Nothing
End Sub

' 我做了一個小小的圖塊管理員, 下面是 userform 的 codes, 主程式只有 Userform1.show.
Public textbox_txt_path As String

Option Explicit

Private Sub CommandButton1_Click()

pick_block_process "c:\block_manager\001.txt"

End Sub

Private Sub pick_block_process(txt_path As String)

On Error Resume Next

Dim file_name As String
Dim file_title As String
Dim dir_name As String
Dim blkref_obj As AcadBlockReference

' 要在 Autocad VBA 使用 CommonDialog 的功能, 必須先安裝 VB 6.0. 再借用裏面的功能.
' CommonDialog 的功能有點像檔案管理員, 可以讓我們選取檔案.

CommonDialog1.InitDir = dir_name ' InitDir = Initialize dir 初始資料夾的路徑

CommonDialog1.ShowOpen ' 打開

file_name = CommonDialog1.FileName ' 含有完整路徑的檔名 例: c:\data_center\slc.dwg
file_title = CommonDialog1.FileTitle ' 只有檔名 例: sga26.dwg

' Left 的功能是從字串左邊取幾個字
dir_name = Left(file_name, Len(file_name) - Len(file_title)) ' 把完整的路徑去除檔名, 只要資料夾

If Len(Dir(txt_path)) <> 0 Then Kill txt_path ' 如果這個檔案存在就刪除

Open txt_path For Append As #1 ' 開檔寫入的功能, Append 是如果檔名不存在會自動建一個新的
    Print #1, dir_name
Close #1

game_over_process

UserForm1.Hide ' 打使用介面的畫面隱藏起來, 因為要插入圖塊.

If Len(file_title) = 0 Then ' 如果沒有選取圖塊, 就回到畫面
  UserForm1.Show
Else
  Dim insert_p As Variant ' 插入圖塊.
  insert_p = tu.GetPoint(, "請點選圖塊插入點 !! ...........")

  If Err Then End

  Set blkref_obj = tm.InsertBlock(insert_p, file_name, 1, 1, 1, 0)
  blkref_obj.Update
 
  End
End If

End Sub

Private Sub CommandButton2_Click()
pick_block_process "c:\block_manager\002.txt"
End Sub

Private Sub CommandButton3_Click()
pick_block_process "c:\block_manager\003.txt"
End Sub

Private Sub CommandButton37_Click()
game_over_process
End
End Sub

Private Sub CommandButton4_Click()
pick_block_process "c:\block_manager\004.txt"
End Sub
Private Sub CommandButton5_Click()
pick_block_process "c:\block_manager\005.txt"
End Sub
Private Sub CommandButton6_Click()
pick_block_process "c:\block_manager\006.txt"
End Sub
Private Sub CommandButton7_Click()
pick_block_process "c:\block_manager\007.txt"
End Sub
Private Sub CommandButton8_Click()
pick_block_process "c:\block_manager\008.txt"
End Sub
Private Sub CommandButton9_Click()
pick_block_process "c:\block_manager\009.txt"
End Sub
Private Sub CommandButton10_Click()
pick_block_process "c:\block_manager\010.txt"
End Sub
Private Sub CommandButton11_Click()
pick_block_process "c:\block_manager\011.txt"
End Sub
Private Sub CommandButton12_Click()
pick_block_process "c:\block_manager\012.txt"
End Sub
Private Sub CommandButton13_Click()
pick_block_process "c:\block_manager\013.txt"
End Sub
Private Sub CommandButton14_Click()
pick_block_process "c:\block_manager\014.txt"
End Sub
Private Sub CommandButton15_Click()
pick_block_process "c:\block_manager\015.txt"
End Sub
Private Sub CommandButton16_Click()
pick_block_process "c:\block_manager\016.txt"
End Sub
Private Sub CommandButton17_Click()
pick_block_process "c:\block_manager\017.txt"
End Sub
Private Sub CommandButton18_Click()
pick_block_process "c:\block_manager\018.txt"
End Sub
Private Sub CommandButton19_Click()
pick_block_process "c:\block_manager\019.txt"
End Sub
Private Sub CommandButton20_Click()
pick_block_process "c:\block_manager\020.txt"
End Sub
Private Sub CommandButton21_Click()
pick_block_process "c:\block_manager\021.txt"
End Sub
Private Sub CommandButton22_Click()
pick_block_process "c:\block_manager\022.txt"
End Sub
Private Sub CommandButton23_Click()
pick_block_process "c:\block_manager\023.txt"
End Sub
Private Sub CommandButton24_Click()
pick_block_process "c:\block_manager\024.txt"
End Sub
Private Sub CommandButton25_Click()
pick_block_process "c:\block_manager\025.txt"
End Sub
Private Sub CommandButton26_Click()
pick_block_process "c:\block_manager\026.txt"
End Sub
Private Sub CommandButton27_Click()
pick_block_process "c:\block_manager\027.txt"
End Sub
Private Sub CommandButton28_Click()
pick_block_process "c:\block_manager\028.txt"
End Sub
Private Sub CommandButton29_Click()
pick_block_process "c:\block_manager\029.txt"
End Sub
Private Sub CommandButton30_Click()
pick_block_process "c:\block_manager\030.txt"
End Sub
Private Sub CommandButton31_Click()
pick_block_process "c:\block_manager\031.txt"
End Sub
Private Sub CommandButton32_Click()
pick_block_process "c:\block_manager\032.txt"
End Sub
Private Sub CommandButton33_Click()
pick_block_process "c:\block_manager\033.txt"
End Sub
Private Sub CommandButton34_Click()
pick_block_process "c:\block_manager\034.txt"
End Sub
Private Sub CommandButton35_Click()
pick_block_process "c:\block_manager\035.txt"
End Sub
Private Sub CommandButton36_Click()
pick_block_process "c:\block_manager\036.txt"
End Sub

Private Sub UserForm_initialize()

On Error Resume Next

Dim text_obj As String
Dim d_count As Integer

textbox_txt_path = "c:\block_manager\textbox_txt.txt"

If Len(Dir(textbox_txt_path)) <> 0 Then
 
  Open textbox_txt_path For Input As #1 ' 將文字檔裏的資料一個一個填到 Textbox1, Textbox2......

       Do While Not EOF(1)    ' Loop until end of file.
   
          Select Case d_count
          Case 0: Line Input #1, text_obj: TextBox1 = text_obj
          Case 1: Line Input #1, text_obj: TextBox2 = text_obj
          Case 2: Line Input #1, text_obj: TextBox3 = text_obj
          Case 3: Line Input #1, text_obj: TextBox4 = text_obj
          Case 4: Line Input #1, text_obj: TextBox5 = text_obj
          Case 5: Line Input #1, text_obj: TextBox6 = text_obj
          Case 6: Line Input #1, text_obj: TextBox7 = text_obj
          Case 7: Line Input #1, text_obj: TextBox8 = text_obj
          Case 8: Line Input #1, text_obj: TextBox9 = text_obj
          Case 9: Line Input #1, text_obj: TextBox10 = text_obj
          Case 10: Line Input #1, text_obj: TextBox11 = text_obj
          Case 11: Line Input #1, text_obj: TextBox12 = text_obj
          Case 12: Line Input #1, text_obj: TextBox13 = text_obj
          Case 13: Line Input #1, text_obj: TextBox14 = text_obj
          Case 14: Line Input #1, text_obj: TextBox15 = text_obj
          Case 15: Line Input #1, text_obj: TextBox16 = text_obj
          Case 16: Line Input #1, text_obj: TextBox17 = text_obj
          Case 17: Line Input #1, text_obj: TextBox18 = text_obj
          Case 18: Line Input #1, text_obj: TextBox19 = text_obj
          Case 19: Line Input #1, text_obj: TextBox20 = text_obj
          Case 20: Line Input #1, text_obj: TextBox21 = text_obj
          Case 21: Line Input #1, text_obj: TextBox22 = text_obj
          Case 22: Line Input #1, text_obj: TextBox23 = text_obj
          Case 23: Line Input #1, text_obj: TextBox24 = text_obj
          Case 24: Line Input #1, text_obj: TextBox25 = text_obj
          Case 25: Line Input #1, text_obj: TextBox26 = text_obj
          Case 26: Line Input #1, text_obj: TextBox27 = text_obj
          Case 27: Line Input #1, text_obj: TextBox28 = text_obj
          Case 28: Line Input #1, text_obj: TextBox29 = text_obj
          Case 29: Line Input #1, text_obj: TextBox30 = text_obj
          Case 30: Line Input #1, text_obj: TextBox31 = text_obj
          Case 31: Line Input #1, text_obj: TextBox32 = text_obj
          Case 32: Line Input #1, text_obj: TextBox33 = text_obj
          Case 33: Line Input #1, text_obj: TextBox34 = text_obj
          Case 34: Line Input #1, text_obj: TextBox35 = text_obj
          Case 35: Line Input #1, text_obj: TextBox36 = text_obj
          End Select
   
          d_count = d_count + 1
       Loop
  Close #1
End If

End Sub

Private Sub game_over_process()

On Error Resume Next

If Len(Dir(textbox_txt_path)) <> 0 Then Kill textbox_txt_path

Open textbox_txt_path For Append As #1 ' 插入圖塊前, 要先將 Textbox 的資料回存文字檔.

    Print #1, TextBox1
    Print #1, TextBox2
    Print #1, TextBox3
    Print #1, TextBox4
    Print #1, TextBox5
    Print #1, TextBox6
    Print #1, TextBox7
    Print #1, TextBox8
    Print #1, TextBox9
    Print #1, TextBox10
    Print #1, TextBox11
    Print #1, TextBox12
    Print #1, TextBox13
    Print #1, TextBox14
    Print #1, TextBox15
    Print #1, TextBox16
    Print #1, TextBox17
    Print #1, TextBox18
    Print #1, TextBox19
    Print #1, TextBox20
    Print #1, TextBox21
    Print #1, TextBox22
    Print #1, TextBox23
    Print #1, TextBox24
    Print #1, TextBox25
    Print #1, TextBox26
    Print #1, TextBox27
    Print #1, TextBox28
    Print #1, TextBox29
    Print #1, TextBox30
    Print #1, TextBox31
    Print #1, TextBox32
    Print #1, TextBox33
    Print #1, TextBox34
    Print #1, TextBox35
    Print #1, TextBox36
   
Close #1

End Sub



▼下載程式：
https://app.box.com/s/qnpsow7ar2azpnqdgqjj

老哥,VBA的推廣,您真的是不遺餘力,
這麼有心,身為人甲的我,只能給你一個讚啦! 
有心學習VBA的朋友,真的不要錯過!

ginse0727 寫到:老哥,VBA的推廣,您真的是不遺餘力,
這麼有心,身為人甲的我,只能給你一個讚啦! 
有心學習VBA的朋友,真的不要錯過!

 是啊～論壇關於VBA文章真的不多，主要是我不擅長...也就沒有辦法參與及分享教學！

感恩 shackle_2005前輩 無私熱心分享～