VB开发CAD菜单

VB能实现cad菜单

2010年09月16日 星期四 下午 07:42

Public Sub CreateMenu()

On Error Resume Next

\\'用AutoCAD菜单组的第一项创建一个菜单组

Dim CurMenuGroup As Object

Set CurMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

\\'创建一个名为“CAD增强插件”的菜单项，设S为加速键

Dim NewMenu As Object

Set NewMenu = CurMenuGroup.Menus.Add(\"CAD增强插件(\" + Chr(Asc(\"&\")) + \"S)\")

\\'确定选择项的宏

Dim FlowMacro As String

\\'为宏分配命令

\\'即VBA中的 ESC ESC 设计流程

FlowMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"DefPipeSize\" & Chr(34) & \")\" & Chr(13)

\\'添加选择项到CAD增强插件菜单项中

Dim FlowMenuItem As Object

Dim SepaMenuItem As Object \\'分隔符

Set FlowMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, Chr(Asc(\"&\")) + \"插入页码\

Set SepaMenuItem = NewMenu.AddSeparator(NewMenu.Count + 1)

\\'创建子菜单

Dim SingleMenu As Object

Set SingleMenu = NewMenu.AddSubMenu(NewMenu.Count + 1, \"横断面修改\")

\\'将选择项添加到子菜单中

Dim SubMenuItem As Object

Dim SubMacro As String

SubMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"Start_HdmBz\" & Chr(34) & \")\" & Chr(13)

Set SubMenuItem = SingleMenu.AddMenuItem(SingleMenu.Count + 1, \"横断面高程标注 \

Set SepaMenuItem = NewMenu.AddSeparator(NewMenu.Count + 1)

\\'即VBA中的 ESC ESC 设计流程

FlowMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"AboutUs\" & Chr(34) & \")\" & Chr(13)

Set FlowMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, Chr(Asc(\"&\")) + \"关于\

FlowMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"SetOption\" & Chr(34) & \")\" & Chr(13)

Set FlowMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, Chr(Asc(\"&\")) + \"设置\

\\'在AutoCAd菜单条上显示新创建的菜单

NewMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)

End Sub

************************

Public Sub CreateMenu()

On Error Resume Next

\\'用AutoCAD菜单组的第一项创建一个菜单组

Dim CurMenuGroup As Object

Set CurMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)

\\'创建一个名为“CAD增强插件”的菜单项，设S为加速键

Dim NewMenu As Object

Set NewMenu = CurMenuGroup.Menus.Add(\"CAD增强插件(\" + Chr(Asc(\"&\")) + \"S)\")

\\'确定选择项的宏

Dim FlowMacro As String

\\'为宏分配命令

\\'即VBA中的 ESC ESC 设计流程

FlowMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"DefPipeSize\" & Chr(34) & \")\" & Chr(13)

\\'添加选择项到CAD增强插件菜单项中

Dim FlowMenuItem As Object

Dim SepaMenuItem As Object \\'分隔符

Set FlowMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, Chr(Asc(\"&\")) + \"插入页码\

Set SepaMenuItem = NewMenu.AddSeparator(NewMenu.Count + 1)

\\'创建子菜单

Dim SingleMenu As Object

Set SingleMenu = NewMenu.AddSubMenu(NewMenu.Count + 1, \"横断面修改\")

\\'将选择项添加到子菜单中

Dim SubMenuItem As Object

Dim SubMacro As String

SubMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"Start_HdmBz\" & Chr(34) & \")\" & Chr(13)

Set SubMenuItem = SingleMenu.AddMenuItem(SingleMenu.Count + 1, \"横断面高程标注 \

Set SepaMenuItem = NewMenu.AddSeparator(NewMenu.Count + 1)

\\'即VBA中的 ESC ESC 设计流程

FlowMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"AboutUs\" & Chr(34) & \")\" & Chr(13)

Set FlowMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, Chr(Asc(\"&\")) + \"关于\

FlowMacro = Chr(3) & Chr(3) & \"(vl-vbarun \" & Chr(34) & \"SetOption\" & Chr(34) & \")\" & Chr(13)

Set FlowMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, Chr(Asc(\"&\")) + \"设置\

\\'在AutoCAd菜单条上显示新创建的菜单

NewMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)

End Sub

*********************

用VB给ACAD添加菜单，调用EXE

我用VB给ACAD添加菜单，调用《绘中心线。EXE》，在执行中，总是先启动DOS命令窗口，怎么才能使其不显示，就象《绘中心线》功能是CAD自己的一样。

Sub Main()

Dim acadapp As AcadApplication

On Error Resume Next

Set acadapp = GetObject(, \"Autocad.Application.16\")

If Err Then

Err.Clear

Set acadapp = CreateObject(\"Autocad.Application.16\")

If Err Then

MsgBox (\"不能运行ACAD，请检查是否安装了ACAD\")

Exit Sub

End If

End If

acadapp.Visible = True

Dim acaddoc As AcadDocument

Set acaddoc = acadapp.ActiveDocument

Dim curlayerobj As Object

Set curlayerobj = acaddoc.ActiveLayer

Dim lineEnt As AcadLineType

Dim found As Boolean

found = False

For Each lineEnt In acaddoc.Linetypes

If StrComp(lineEnt.Name, \"DASHDOTX2\

found = True

Exit For

End If

Next

If Not (found) Then

acaddoc.Linetypes.Load \"DASHDOTX2\

End If

Set newlayerObj = acaddoc.Layers.Add(\"aidLayer\")

acaddoc.ActiveLayer = newlayerObj

newlayerObj.Color = acGreen

newlayerObj.Linetype = \"DASHDOTX2\"

'获得轴线的两个端点

Dim lsPnt As Variant

Dim lePnt As Variant

Dim aixlineObj As AcadLine

lsPnt = acaddoc.Utility.GetPoint(, \"输入第一点：\")

lePnt = acaddoc.Utility.GetPoint(, \"输入第二点：\")

Set aixlineObj = acaddoc.ModelSpace.AddLine(lsPnt, lePnt)

Dim midPnt(0 To 2) As Double

midPnt(0) = (lsPnt(0) + lePnt(0)) / 2

midPnt(1) = (lsPnt(1) + lePnt(1)) / 2

midPnt(2) = 0

'以轴线的中点为基点将其加长1。1倍

aixlineObj.ScaleEntity midPnt, 1.1

'将线型比例因子放大10倍

aixlineObj.LinetypeScale = 10

aixlineObj.Update

'灰复原来图层

acaddoc.ActiveLayer = curlayerobj

End Sub

菜单加载程序是用宏命令。