社区 › 编程申请 › [求助]如何利用VBA在CAD中直接提取坐标并生成表格

xmjiacad 发表于 2009-11-26 21:04:00

我也好想知道怎么做啊

逐月 发表于 2012-12-24 11:37:02

怎么还要密码呀

pipilu1984 发表于 2013-11-8 16:59:45

这么久了呀

nzl1116 发表于 2013-11-9 00:49:56

pipilu1984 发表于 2013-11-8 16:59 static/image/common/back.gif
这么久了呀

还真佩服楼主的毅力

pipilu1984 发表于 2013-11-11 14:52:04

nzl1116 发表于 2013-11-9 00:49 static/image/common/back.gif
还真佩服楼主的毅力

没事转转

万里天 发表于 2013-12-19 02:00:01

给大家分享源码吧:
Sub Start()
    UserForm1.Show
End Sub

Private Function SetMenu(MenuStr As String, Optional Macro As String = "", Optional HelpString As String = "")
    Dim M
    M = Split(MenuStr, "/")
    Dim CADMenuGroup As AcadMenuGroup
    Set CADMenuGroup = Application.MenuGroups(0)
    On Error Resume Next
    Dim NewMenu As AcadPopupMenu
    Set NewMenu = CADMenuGroup.Menus.Add(M(0))
    If Err Then Set NewMenu = CADMenuGroup.Menus(M(0))
    Dim MenuIndex As Integer, MenuLevel As Integer
    Dim NewMenuItem As AcadPopupMenuItem
    Dim i As Integer
    MenuLevel = UBound(M)
   
    For i = 1 To MenuLevel - 1
      MenuIndex = GetIndex(NewMenu, M(i))
      If MenuIndex = -1 Then
            Set NewMenu = NewMenu.AddSubMenu(NewMenu.Count + 1, M(i))
      Else
            Set NewMenu = NewMenu(MenuIndex).SubMenu
      End If
    Next
    NewMenu(GetIndex(NewMenu, M(MenuLevel))).Delete
    If M(MenuLevel) <> "-" Then
      Err.Clear
      Set NewMenuItem = NewMenu.AddMenuItem(NewMenu.Count + 1, M(MenuLevel), VBAMacro(Macro))
      If Err Then MsgBox Err.Description
      NewMenuItem.HelpString = HelpString
      CADMenuGroup.Menus.InsertMenuInMenuBar M(0), ""
    Else
      Set NewMenuItem = NewMenu.AddSeparator(NewMenu.Count + 1)
    End If

    If NewMenu.Count = 0 Then NewMenu.Parent.Delete
    If CADMenuGroup.Menus(M(0)).Count = 0 Or MenuLevel = 0 Then
      CADMenuGroup.Menus(M(0)).RemoveFromMenuBar
    End If


End Function
Private Sub AddSeparator(Menu As String)
    With GetMenu(Menu)
      .AddSeparator .Count + 1
    End With
End Sub
Public Function GetMenu(Menu As String) As AcadPopupMenu
    On Error Resume Next
    Dim M
    M = Split(Menu, "/")
   
    Dim CADMenuGroup As AcadMenuGroup
    Set CADMenuGroup = Application.MenuGroups(0)
    On Error Resume Next
    Dim NewMenu As AcadPopupMenu
    Set GetMenu = CADMenuGroup.Menus.Add(Menu)
    If Err Then Set GetMenu = CADMenuGroup.Menus(M(0))
   
    Dim MenuIndex As Integer, MenuLevel As Integer
    Dim NewMenuItem As AcadPopupMenuItem
    Dim i As Integer
    MenuLevel = UBound(M)
    Set NewMenu = GetMenu
    For i = 1 To MenuLevel '- 1
      MenuIndex = GetIndex(NewMenu, M(i))
      If MenuIndex = -1 Then
            Set NewMenu = NewMenu.AddSubMenu(NewMenu.Count + 1, M(i))
      Else
            Set NewMenu = NewMenu(MenuIndex).SubMenu
      End If
    Next
    Set GetMenu = NewMenu

End Function

Private Function GetIndex(Menu As AcadPopupMenu, Caption) As Integer
    Dim i As Integer
    For i = 0 To Menu.Count - 1
      If UCase(Caption) = UCase(Menu.Item(i).Caption) Then
            GetIndex = i
            Exit Function
      End If
    Next
    GetIndex = -1
End Function

Private Function VBAMacro(Macro As String) As String
    VBAMacro = Chr(3) & Chr(3) & "-VBARUN " & Macro & vbCr
End Function

Private Sub DelMenu(Menu As String)
    On Error Resume Next
    Dim M As AcadPopupMenu, M1 As AcadPopupMenu, i As Integer
    Set M = GetMenu(Menu)
    For i = M.Count - 1 To 0 Step -1
      M(i).Delete
    Next
    Set M = GetMenu(Menu)
    If M.Count = 0 Then M.RemoveFromMenuBar
End Sub

Sub CreateMenu()
    SetMenu "我的工具箱/坐标选择", "Start", "打开坐标选择窗口"
End Sub

nj简简单单jn 发表于 2015-5-4 10:43:54

万里天 发表于 2013-12-19 02:00 static/image/common/back.gif
给大家分享源码吧:
Sub Start()
    UserForm1.Show


能不能再把窗体的设置图和控件的命名给出来呢，谢谢谢谢

查看完整版本: [求助]如何利用VBA在CAD中直接提取坐标并生成表格