Question

会Auto CAD VBA的进来，帮忙编写一段程序，会的留下邮箱，我会把要求发到邮箱。非常感谢！

实体编程

Answer 1

Option Explicit

'************************************************************************************************
'* *
'* 　　　　　工具栏和菜单 *
'* *
'************************************************************************************************
Public Sub AcadStartup1()
InsertMenus
End Sub

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

'创建新的菜单
Dim newMenu As AcadPopupMenu
Set newMenu = currMenuGroup.Menus.Add("自定义菜单(&M)")

'添加一个菜单项的子菜单
Dim newMenuItem As AcadPopupMenuItem
Dim openMacro As String
Dim FileSubMenu As AcadPopupMenu
'添加子菜单

' 将宏指定字符串相当于 ESC ESC _open
openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN SayHi" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "姓名和学号", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN OpenAFile" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "打开模型文件", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN Make3DSolid1" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "绘制3D模型1", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN Make3DSolid2" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "绘制3D模型2", openMacro)

Set newMenuItem = newMenu.AddSeparator(newMenu.Count)

Set FileSubMenu = newMenu.AddSubMenu(newMenu.Count + 1, "绘制2D实体")

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN MkLine" & Chr(32)
Set newMenuItem = FileSubMenu.AddMenuItem(newMenu.Count + 1, "绘制直线(&L)", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN MkPolyline" & Chr(32)
Set newMenuItem = FileSubMenu.AddMenuItem(newMenu.Count + 1, "绘制多段线(&P)", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN MkCircle" & Chr(32)
Set newMenuItem = FileSubMenu.AddMenuItem(newMenu.Count + 1, "绘制圆(&C)", openMacro)

openMacro = Chr(3) & Chr(3) & Chr(95) & "-VBARUN OpenAFile" & Chr(32)
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "&Open File...", openMacro)

'显示菜单栏上的的菜单
newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)

End Sub

Public Sub SayHi()
MsgBox "姓名：×××　　学号：××××××", , "姓名和学号"
End Sub

Public Sub OpenAFile()
ThisDrawing.SendCommand "_OPEN "
End Sub

Public Sub MkLine()
ThisDrawing.SendCommand "_Line "
End Sub

Public Sub MkPolyline()
ThisDrawing.SendCommand "_PLine "
End Sub

Public Sub MkCircle()
ThisDrawing.SendCommand "_CIRCLE "
End Sub

Public Sub Make3DSolid1()
Dim objBox As Acad3DSolid, objSphere As Acad3DSolid, dblCenter(2) As Double

With ThisDrawing.ModelSpace

Set objBox = .AddBox(dblCenter, 100, 100, 100)

dblCenter(1) = 50

Set objSphere = .AddSphere(dblCenter, 45)

objBox.Boolean acSubtraction, objSphere

ZoomAll

End With

End Sub

Public Sub Make3DSolid2()

End Sub