VBA for AutoCAD

[votinh66]

Cách tạo và xoá menu:
(Vì tôi sử dụng AutoCAD 2006 nên tất cả các bài viết đều thực hiện trên phiên bản này).
Trong AutoCAD nhấn Alt+F11 để mở Microsoft Visual Basic.
Nháy đúp chuột vào This Drawing, rồi thêm đoạn mã sau:

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

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):

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 AddMenuItemText

Nế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:

(defun S::STARTUP() 
    (command "_VBALOAD" "mnuTextR16.dvb") 
    (command "_-vbarun" "AddMenuItemText")
)

Em muốn thêm 1 số menu con vào nữa thì thêm vào đoạn code như thế nào?Ví dụ như thêm Add text1,Add text2 vào trong Add text.Cám ơn các anh!

 

[nvson]

Em muốn thêm 1 số menu con vào nữa thì thêm vào đoạn code như thế nào?Ví dụ như thêm Add text1,Add text2 vào trong Add text.Cám ơn các anh!

Bạn sử dụng thuộc tính AddSubMenu để tạo các menu con (phụ).
Bạn tham khảo đoạn code tạo menu con mà mình lấy trong Help của AutoCad nhé!

Sub Ch6_AddASubMenu()
    Dim currMenuGroup As AcadMenuGroup
    Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
 
    ' Create the new menu
    Dim newMenu As AcadPopupMenu
    Set newMenu = currMenuGroup.Menus.Add("TestMenu")
 
    ' Add the submenu
    Dim FileSubMenu As AcadPopupMenu
    Set FileSubMenu = newMenu.AddSubMenu("", "OpenFile")
 
    ' Add a menu item to the sub menu
    Dim newMenuItem As AcadPopupMenuItem
    Dim openMacro As String
    ' Assign the macro the VB equivalent of "ESC ESC _open "
    openMacro = Chr(3) + Chr(3) + "_open "
    Set newMenuItem = FileSubMenu.AddMenuItem(newMenu.Count + 1, "Open", openMacro)
 
    ' Display the menu on the menu bar
    newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
End Sub

 

[thao_tedi]

Em mới tập viết một VBA vẽ lưới toạ độ N, E nhưng không biết cách tạo form trong VBA . Form có dạng Pick điểm thứ nhất và thứ 2 của vùng định vẽ lưới, chọn khoảng cách giữa các lưới theo trục X và trục Y, một nút bấm OK và một nút bấm cancel. Các bác có kinh nghiệm về VBA giúp em với. Link file là http://www.cadviet.com/upfiles/line_Cor_Thao.dvb
Đây là đoạn mã của VBA cho vẽ lưới toạ độ (cái này thì chạy ngon).
Sub duongthang()
Dim lineObj1 As AcadLine
Dim lineObj2 As AcadLine
Dim startPoint As Variant
Dim endPoint As Variant
Dim startPoint1(0 To 2) As Double
Dim endPoint1(0 To 2) As Double
Dim startPoint2(0 To 2) As Double
Dim endPoint2(0 To 2) As Double
Dim Xaxis As Integer
Dim Yaxis As Integer
Dim X1 As Long
Dim Y1 As Long
Dim X2 As Long
Dim Y2 As Long
' Define the start and end points for the area
startPoint = ThisDrawing.Utility.GetPoint(, "Enter a first point: ")
endPoint = ThisDrawing.Utility.GetPoint(, "Enter a second point: ")
Xaxis = ThisDrawing.Utility.GetInteger("Enter distance of X axis:")
Yaxis = ThisDrawing.Utility.GetInteger("Enter distance of Y axis:")
X1 = Round(startPoint(0) / Xaxis, 0) * Xaxis
Y1 = Round(startPoint(1) / Yaxis, 0) * Yaxis
X2 = Round(endPoint(0) / Xaxis, 0) * Xaxis
Y2 = Round(endPoint(1) / Yaxis, 0) * Yaxis
MsgBox "The Coordinate of the first point is: " & X1 & ", " & Y1 & ", " & 0
MsgBox "The Coordinate of the second point is: " & X2 & ", " & Y2 & ", " & 0
startPoint1(0) = X1 + 10: startPoint1(1) = Y1 - 0: startPoint1(2) = 0
endPoint1(0) = X1 - 10: endPoint1(1) = Y1 - 0: endPoint1(2) = 0
startPoint2(0) = X1 - 0: startPoint2(1) = Y1 - 10: startPoint2(2) = 0
endPoint2(0) = X1 - 0: endPoint2(1) = Y1 + 10: endPoint2(2) = 0
' Create the cross line in model space with length is 4
Set lineObj1 = ThisDrawing.ModelSpace.AddLine(startPoint1, endPoint1)
Set lineObj2 = ThisDrawing.ModelSpace.AddLine(startPoint2, endPoint2)
Dim layerObj As AcadLayer
Set layerObj = ThisDrawing.Layers.Add("Grid")
lineObj1.Layer = "Grid"
lineObj1.Update
lineObj2.Layer = "Grid"
lineObj2.Update
ZoomAll
'Create cross line grid
Dim retObjec1 As Variant
Dim retObjec2 As Variant
Dim numberOfRows As Long
Dim numberOfColumns As Long
Dim numberOfLevels As Long
Dim distanceBwtnRows As Double
Dim distanceBwtnColumns As Double
Dim distanceBwtnLevels As Double
numberOfRows = Round((Y2 - Y1) / Yaxis, 0) + 1
numberOfColumns = Round((X2 - X1) / Xaxis, 0) + 1
numberOfLevels = 1
distanceBwtnRows = Yaxis
distanceBwtnColumns = Xaxis
distanceBwtnLevels = 1
retObj1 = lineObj1.ArrayRectangular(numberOfRows, numberOfColumns, numberOfLevels, distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels)
retObj2 = lineObj2.ArrayRectangular(numberOfRows, numberOfColumns, numberOfLevels, distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels)
'Create Coordinate text at the cross line
Dim CoordinteN As Long
Dim CoordinteE As Long
Dim textObj1 As AcadText
Dim textObj2 As AcadText
Dim textStringN As String
Dim textStringE As String
Dim insertionPoint(0 To 2) As Double
Dim N As Double
Dim E As Double
Dim height As Double
Dim i As Integer
For i = 0 To Round((numberOfColumns - 1) / 2) Step 1
E = X1 + Xaxis * i * 2
insertionPoint(0) = E + 1: insertionPoint(1) = Y1 + 11: insertionPoint(2) = 0
height = 2
textStringE = "E " & Round(E, 4) & ".000"
Set textObj1 = ThisDrawing.ModelSpace.AddText(textStringE, insertionPoint, height)
textObj1.Rotation = 1.570796327
textObj1.Layer = "Grid"
textObj1.Update
retObj1 = textObj1.ArrayRectangular(Round((numberOfRows / 2), 0), 1, numberOfLevels, distanceBwtnRows * 2, distanceBwtnColumns * 2, distanceBwtnLevels)
Next
For i = 0 To Round((numberOfRows - 1) / 2) Step 1
N = Y1 + Yaxis * 2 * i
insertionPoint(0) = X1 + 11: insertionPoint(1) = N - 1: insertionPoint(2) = 0
height = 2
textStringN = "N " & Round(N, 4) & ".000"
Set textObj2 = ThisDrawing.ModelSpace.AddText(textStringN, insertionPoint, height)
textObj2.Rotation = 0
textObj2.Layer = "Grid"
textObj2.Update
retObj2 = textObj2.ArrayRectangular(1, Round((numberOfColumns / 2), 0), numberOfLevels, distanceBwtnRows * 2, distanceBwtnColumns * 2, distanceBwtnLevels)
Next
ZoomExtents
End Sub

Còn đây là mã của Userform (Em chưa biết làm cách nào để khi chạy file dvb thì nó sẽ hiện ra một bảng có các lựa chọn pick điểm, nhập khoảng cách phương X, phương Y, OK, cancel...)
Private Sub CommandButton1_Click() 'Dùng để pick tọa độ điểm 1

End Sub

Private Sub CommandButton2_Click() 'Dùng để pick tọa độ điểm 2

End Sub

Private Sub Label1_Click() ' Chọn giá trị khoảng cách theo trục X

End Sub

Private Sub Label2_Click() ' Chọn giá trị khoảng cách theo trục Y

End Sub

Private Sub TextBox1_Change() ' Nhập giá trị khoảng cách theo trục X

End Sub
Private Sub TextBox2_Change() ' Nhập giá trị khoảng cách theo trục X

End Sub
Private Sub CommandButton3_Click() ' Nút OK

End Sub

Private Sub CommandButton4_Click() ' Nút Cancel

End Sub

Private Sub UserForm_Click()

End Sub

 

[qhthong]

Hỏi về cách dùng lệnh MTEXT trong VBA!

Em đang lập 01 đoạn Code vẽ Văn bản mô tả lớp đất, trích dẫn 01 đoạn như sau:
'Ve text mo ta dat
Pt7(0) = 81
Pt7(1) = 100
Set MtextObj = moSpace.AddMText(Pt7, 60, "cat pha, xam vang, trang thai chat vua")
MtextObj.Height = 10
MtextObj.Alignment = acAlignmentMiddleCenter
MtextObj.TextAlignmentPoint = Pt7
MtextObj.Layer = "2"
Err.Clear
MtextObj.StyleName = "2"
Nhưng các quá trình thực thi lại không canh được lề MC như em muốn mà chỉ chạy canh lề dạng TopLeft (TL).
Kính nhờ anh Hướng và các cao thủ giúp em với!

 

[nvson]

Em đang lập 01 đoạn Code vẽ Văn bản mô tả lớp đất, trích dẫn 01 đoạn như sau:
'Ve text mo ta dat
Pt7(0) = 81
Pt7(1) = 100
Set MtextObj = moSpace.AddMText(Pt7, 60, "cat pha, xam vang, trang thai chat vua")
MtextObj.Height = 10
MtextObj.Alignment = acAlignmentMiddleCenter
MtextObj.TextAlignmentPoint = Pt7
MtextObj.Layer = "2"
Err.Clear
MtextObj.StyleName = "2"
Nhưng các quá trình thực thi lại không canh được lề MC như em muốn mà chỉ chạy canh lề dạng TopLeft (TL).
Kính nhờ anh Hướng và các cao thủ giúp em với!

Canh chỉnh Text trong AutoCad bằng VBA:
- Khi sử dụng AddText:

Sub Example_AddText()
    ' This example creates a text object in model space.
    Dim textObj As AcadText
    Dim textString As String
    Dim insertionPoint(0 To 2) As Double
    Dim height As Double
    
    ' Define the text object
    textString = "Hello, World 1."
    insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0
    height = 0.5
    
    ' Create the text object in model space
    Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
    [COLOR=red][B]textObj.Alignment = acAlignmentCenter[/B][/COLOR]
    ZoomAll
    
End Sub

- Khi sử dụng AddMText:

Sub Example_AttachmentPoint()
    Dim MTextObj As AcadMText  
    Dim width As Double
    Dim text As String
    Dim corner(0 To 2) As Double
        
    corner(0) = 3#: corner(1) = 3#: corner(2) = 0#
    width = 100
    text = "Hello, World 2."
    ' Creates a MText object in model space
    Set MTextObj = ThisDrawing.ModelSpace.AddMText(corner, width, text)
   [COLOR=red][B] MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
[/B][/COLOR]       
    ThisDrawing.Regen True
End Sub

 

[qhthong]

Canh chỉnh Text trong AutoCad bằng VBA:
[/CODE]
MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
End Sub
[/CODE]

Hay quá! Cảm ơn anh Son nhiều nhiều,...

 

[buivanhop]

Chậc chậc, bên giaiphapexcel nhiều cao thủ VBA quá,nhân đây các cao thủ cho em hỏi em muốn lập trình cho AutoCAD tự động in như thế này:
Vì em làm nhiều bản vẽ mà em hay để trong Layout (trong cùng 1 layout cho dễ tham chiếu/kiểm tra) nên em đã tạo sẵn các Page Setup trong đó đã có cấu hình đầy đủ để in như máy in, đường nét, vùng cần in...Bi giờ em muốn lập trình VB cho file đó, rồi chạy ra lệnh cho nó in các Page Setup ở trên, các cao thủ giúp em vụ này với nhé, hj...em là amatour VBA mà.
Các bác xem file đính kèm giúp em nha,
http://www.mediafire.com/?x0paw9waz6vkk6b
Mình chỉ cần làm 1 file sau đó sang các bản vẽ khác thì import Page Seup sang cho nó nhanh

 

[son12a2]

Thân gửi các thành viên diễn đàn!

Mình có một vấn đề như sau:
- Mình tạo 1 UserForm bằng VBA trong AutoCad, sau đó có các TextBox để nhập số liệu để vẽ 1 hình. Sau khi nhập xong sẽ lưu vào 1 mảng dữ liệu DL(i).
- Mình muốn xuất số liệu trong mảng DL(i) qua Excel để xử lý, sau đó dùng số liệu đó để nhập lại vào AutoCAD và dùng AutoLisp để vẽ hình hoặc từ VBA xuất mảng dữ liệu DL(i) thành 1 file text để AutoLisp có thể đọc được.
Do kiến thức còn hạn chế nên rất mong mọi người giúp đỡ. (Nếu được thì giúp mình 2 cách luôn nhé vì mình muốn so sanh xem phương án nào khả thi hơn đối với trường hợp của mình). Cảm ơn mọi người rất nhiều!