Tao menu trong VBA & autocad

Sub AddMenuItemText()
Dim currMenuGroup As AcadMenuGroup
Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

' Create the new menu
Dim newMenu As AcadPopupMenu
Set newMenu = currMenuGroup.Menus.Add("Text")

' Add a menu item to the new menu
Dim newMenuItem As AcadPopupMenuItem
Dim openMacro As String

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN AddTextNew" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "Add Text", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN AddMTextNew" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "Add MText", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN MTE" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "Edit Text", openMacro)

' Display the menu on the menu bar
newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
End Sub

Code:
Public Sub removeMenu()
'this macro removes the submenu created by the addMenuItem macro
Dim oAcad As AcadApplication
Set oAcad = ThisDrawing.Application
Dim oPopup As AcadPopupMenu
Dim oPopupItem As AcadPopupMenuItem
For Each oPopup In oAcad.MenuBar
If oPopup.TagString = "ID_mnuText" Then
oPopup.RemoveFromMenuBar
oPopup.Delete
End If
Next oPopup
End Sub


Các thủ tục (macro):
Code:

Sub AddTextNew()
Dim textObj As AcadText
Dim textString As String
Dim textHeight As Double
Dim textPoint As Variant
textPoint = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
textHeight = ThisDrawing.Utility.GetReal("Text height: ")
textString = InputBox("Text: ", "Nguyen Van Son")
Set textObj = ThisDrawing.ModelSpace.AddText(textString, textPoint, textHeight)
End Sub

Sub AddMtextNew()
Dim mtextObj As AcadMText
Dim width As Double
Dim MtextPoint As Variant
Dim MtextString As String

MtextPoint = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
MtextString = InputBox("MText: ", "Nguyen Van Son")
width = 100
Set mtextObj = ThisDrawing.ModelSpace.AddMText(MtextPoint, width, MtextString)
'mtextObj.textString = "OK"

End Sub

Public Sub MTE()
On Error Resume Next
' Create the selection set
Dim ssetObj As AcadSelectionSet
Dim text_New As String
Dim str_Name As String

If Not IsNull(ThisDrawing.SelectionSets.Item("Text")) Then
Set ssetObj = ThisDrawing.SelectionSets.Item("Text")
ssetObj.Delete
End If
Set ssetObj = ThisDrawing.SelectionSets.Add("Text")

'str_Name = Hour(Time) & Minute(Time) & Second(Time)
'Set ssetObj = ThisDrawing.SelectionSets.Add(str_Name)

' Add objects to a selection set by prompting user to select on the screen
ssetObj.SelectOnScreen
For i = 0 To ssetObj.Count - 1
If ssetObj.Item(i).ObjectName = "AcDbMText" Or ssetObj.Item(i).ObjectName = "AcDbText" Then
text_New = InputBox("Nhap doan text moi: ", "Nguyen Van Son", ssetObj.Item(i).textString)
ssetObj.Item(i).textString = text_New
ssetObj.Update
End If
Next
End
End Sub

Ghi lại thành file mnuTextR16.dvb trong thư mục C:\Program Files\AutoCAD 2006\Support. Nếu ghi ở thư mục khác thì trong ACad đánh lệnh options, chọn tab Files, sau đó Add đường dẫn tới file mnuTextR16.dvb.Chạy Macro AddMenuItemTextNếu muốn các lần sau menu trên tự chạy thì chỉnh sửa file acad2006.lsp trong thư mục C:\Program Files\AutoCAD 2006\Support:Thêm đoạn code sau vào cuối file:
Code:
(defun S::STARTUP()
(command "_VBALOAD" "mnuTextR16.dvb")
(command "_-vbarun" "AddMenuItemText")
)