【AutoCAD二次开发】第十一节 菜单和工具栏

'第十一节 菜单和工具栏
Sub CreateMenuExample()
  '创建菜单组
  Dim mnuGroup As AcadMenuGroup
  Set mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)
  '创建新菜单
  Dim mnuTest As AcadPopupMenu
  Set mnuTest = mnuGroup.Menus.Add("测ta试(&T)")
  '创建下拉菜单，执行自编的VBA程序GETP
  Dim mnuGetP As AcadPopupMenuItem
  Dim macGetP As String
  macGetP = Chr(3) & Chr(3) & Chr(95) & _
            "-vbarun" & Chr(32) & "GETP" & Chr(32)
  Set mnuGetP = mnuTest.AddMenuItem _
               (mnuTest.Count + 1, "获取实体编码(&G)", macGetP)
  '创建分隔线
  Dim mnuSeparator As AcadPopupMenuItem
  Set mnuSeparator = mnuTest.AddSeparator("")
  '创建下拉菜单，执行AutoCAD内部命令
  Dim mnuCopy As AcadPopupMenuItem
  Dim macCopy As String
  macCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)
  Set mnuCopy = mnuTest.AddMenuItem _
                (mnuTest.Count + 1, "&Copy", macCopy)
  '创建子菜单
  Dim mnuFather As AcadPopupMenu
  Set mnuFather = mnuTest.AddSubMenu(mnuTest.Count + 1, "父菜单")
  Dim mnuChild As AcadPopupMenuItem
  Dim macChild As String
  macChild = Chr(3) & Chr(3) & Chr(95) & "export" & Chr(32)
  Set mnuChild = mnuFather.AddMenuItem _
                (mnuTest.Count + 1, "子菜单-导出其他格式", macChild)
  '在菜单条上显示菜单
  mnuTest.InsertInMenuBar ThisDrawing.Application.MenuBar.Count + 1
  '删除菜单
  If MsgBox("是否删除COPY菜单?", vbYesNo, "AutoCAD提示") = vbYes Then
     mnuCopy.Delete
  End If
End Sub
Sub CreateToolbarExample()
  Dim mnuGroup As AcadMenuGroup
  Dim tbTest As AcadToolbar
  Dim tbCopy As AcadToolbarItem
  Dim tbPaste As AcadToolbarItem
  Dim tbSeparator As AcadToolbarItem
  Dim macCopy As String
  Dim macPasteclip As String
  Dim strPath1 As String
  Dim strPath2 As String
  Set mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)
  Set tbTest = mnuGroup.Toolbars.Add("测试111")
  macCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)
  macPaste = Chr(3) & Chr(3) & Chr(95) & "pasteclip" & Chr(32)
  Set tbCopy = tbTest.AddToolbarButton _
                (tbTest.Count + 1, "复制", "复制", macCopy, False)
  Set tbPaste = tbTest.AddToolbarButton _
                (tbTest.Count + 1, "粘贴", "粘贴", macPaste, False)
  Set tbSeparator = tbTest.AddSeparator(tbTest.Count + 1)
  '设置图标
  strPath1 = "G:\VBA\copy.bmp"
  strPath2 = "G:\VBA\copy.bmp"
  tbCopy.SetBitmaps strPath1, strPath2
  strPath1 = "G:\VBA\paste.bmp"
  strPath2 = "G:\VBA\paste.bmp"
  tbPaste.SetBitmaps strPath1, strPath2
  MsgBox "现在把工具条泊位到屏幕左边"
  tbTest.Dock acToolbarDockLeft
  MsgBox "现在把工具条浮动到指定位置"
  tbTest.Float 550, 300, 1
End Sub