[求助]请问哪里有cad工具栏的源代码下载哦

weisuolong

刚刚学习cad的VBA

原来用过excel的vba  里面的桌面的菜单的命令 都可以通过录制宏代码的方式获得

但是cad没有这个功能

请问如果我想得到这些菜单的代码的话  怎么办哦。。。。。。

谢谢哦

虎年快乐   恭喜发财哦

jerry1988

网上到处都有。。。论坛里也有。。。希望你能看得懂，这是我自己的。。。

 

Option Explicit

Sub AddToolbar()
    Dim currMenuGroup As AcadMenuGroup
    Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
   
    Dim smallbitmapname(5) As String
    Dim largebitmapname(5) As String
   
    '创建第一个工具栏***************************************************************
    Dim newToolBar As AcadToolbar
    Set newToolBar = currMenuGroup.Toolbars.Add("船舶辅助设计工具条")
   
    '在工具栏上添加按钮
    Dim newButton(3) As AcadToolbarItem
    Dim openMacro(5) As String
    Dim newtoolBarSeparator As AcadToolbarItem
   
    '指定宏代码的值
    'openMacro(0) = "-vbarun" + Chr(32) + "newproject" + Chr(32)
    '相当于在命令行中执行"ESC ESC _new "
    openMacro(0) = Chr(3) & Chr(3) & Chr(95) & "new" & Chr(32)
    openMacro(1) = Chr(3) & Chr(3) & Chr(95) & "open" & Chr(32)
    openMacro(2) = Chr(3) & Chr(3) & Chr(95) & "save" & Chr(32)
    openMacro(3) = Chr(3) & Chr(3) & Chr(95) & "cutclip" & Chr(32)
    openMacro(4) = Chr(3) & Chr(3) & Chr(95) & "copyclip" & Chr(32)
    '在工具栏中调用宏
    openMacro(5) = Chr(3) & Chr(3) & "-vbarun" + Chr(32) + "ThisDrawing.Drawline" + Chr(32)

   
    Set newButton(0) = newToolBar.AddToolbarButton(newToolBar.Count + 1, "新建图形", "新建图形", openMacro(0))
    Set newButton(1) = newToolBar.AddToolbarButton(newToolBar.Count + 1, "打开图形", "打开图形", openMacro(1))
    Set newButton(2) = newToolBar.AddToolbarButton(newToolBar.Count + 1, "保存图形", "保存图形", openMacro(2))
    '将该按钮设置为Flyout按钮
    Set newButton(3) = newToolBar.AddToolbarButton(newToolBar.Count + 1, "剪切", "剪切", "open", True)
    '注意分隔线在工具栏中的位置，在“剪切”按钮之前
    Set newtoolBarSeparator = newToolBar.AddSeparator(newToolBar.Count + 1)
   
    '创建第二个工具栏*****************************************************************
    Dim newToolBar2 As AcadToolbar
    Set newToolBar2 = currMenuGroup.Toolbars.Add("船舶辅助设计工具条2")
    '添加工具按钮
    Dim newButton2(2) As AcadToolbarItem
    Set newButton2(0) = newToolBar2.AddToolbarButton(newToolBar2.Count + 1, "复制到剪贴板", "复制到剪贴板", openMacro(3))
    Set newButton2(1) = newToolBar2.AddToolbarButton(newToolBar2.Count + 1, "复制", "复制", openMacro(4))
    Set newButton2(2) = newToolBar2.AddToolbarButton(newToolBar2.Count + 1, "粘贴", "粘贴", openMacro(5))
   
    Dim pathL As String, pathS As String
    pathL = "E:\AutoCAD\Icons\Large\"
    pathS = "E:\AutoCAD\Icons\Small\"
    '设置第1个按钮的图标
    smallbitmapname(0) = pathS & "new.bmp"
    largebitmapname(0) = pathL & "new.bmp"
    newButton(0).SetBitmaps smallbitmapname(0), largebitmapname(0)
    '设置第2个按钮的图标
    smallbitmapname(1) = pathS & "open.bmp"
    largebitmapname(1) = pathL & "open.bmp"
    newButton(1).SetBitmaps smallbitmapname(1), largebitmapname(1)
    '设置第3个按钮的图标
    smallbitmapname(2) = pathS & "save.bmp"
    largebitmapname(2) = pathL & "save.bmp"
    newButton(2).SetBitmaps smallbitmapname(2), largebitmapname(2)
   
   
    '设置第4个按钮的图标
    smallbitmapname(3) = pathS & "cut.bmp"
    largebitmapname(3) = pathL & "cut.bmp"
    newButton2(0).SetBitmaps smallbitmapname(3), largebitmapname(3)
    '设置第5个按钮的图标
    smallbitmapname(4) = pathS & "copy.bmp"
    largebitmapname(4) = pathL & "copy.bmp"
    newButton2(1).SetBitmaps smallbitmapname(4), largebitmapname(4)
    '设置第6个按钮的图标
    smallbitmapname(5) = pathS & "paste.bmp"
    largebitmapname(5) = pathL & "paste.bmp"
    newButton2(2).SetBitmaps smallbitmapname(5), largebitmapname(5)
   
    '将第二个工具栏附着到第一个工具栏上的Flyout按钮
    newButton(3).AttachToolbarToFlyout currMenuGroup.Name, newToolBar2.Name
   
    '调整工具栏的显示
    newToolBar.Visible = True
    newToolBar2.Visible = True
   
    Exit Sub
ErrorLine:
    MsgBox "在宏的执行过程中发生如下的错误：" & Err.Description
   
End Sub

Sub Drawline()
    Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double
    pt1(0) = 100: pt1(1) = 100: pt1(2) = 0
    pt2(0) = 200: pt2(1) = 200: pt2(2) = 0
   
    ThisDrawing.ModelSpace.AddLine pt1, pt2
   
    ZoomExtents
End Sub