[求助]如何利用VBA在CAD中直接提取坐标并生成表格

xmjiacad

我也好想知道怎么做啊

逐月

怎么还要密码呀

pipilu1984

这么久了呀

nzl1116

pipilu1984 发表于 2013-11-8 16:59
这么久了呀

还真佩服楼主的毅力

pipilu1984

nzl1116 发表于 2013-11-9 00:49
还真佩服楼主的毅力

没事转转

万里天

给大家分享源码吧:
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

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

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