Acad 工具栏和按钮

Public Function CreateButton(ThisToolBar As AcadToolbar, strSettings As String) As Boolean
Dim ToolbarName As String
'Create new buttons
Dim newButton As AcadToolbarItem
Dim varSettings As Variant
Dim strName As String
Dim strDescription As String
Dim strMacro As String
Dim BitmapName  As String
Dim SmallBitmapName  As String
On Error GoTo Err_Control
 '0 = Name
 '1 = Description
 '2 = Macro
 '3 = Icon
 
 varSettings = Split(strSettings, "|")
 
 'Assign the macro string the VB equivalent of "ESC ESC _open "
 'openMacro = Chr(3) & Chr(3) & Chr(95) & "open" & Chr(32)
 strName = varSettings(0)
 strDescription = varSettings(1)
 strMacro = Chr(3) & Chr(3) & varSettings(2) & Chr(13)
 Set newButton = ThisToolBar.AddToolbarButton("", strName, strDescription, strMacro)
 'Assign Bitmap Image to Button
 SmallBitmapName = varSettings(3)
 newButton.SetBitmaps SmallBitmapName, SmallBitmapName
 'Display the toolbar
 ThisToolBar.Visible = True
     
Exit_Here:
 Exit Function
  
Err_Control:
 Select Case Err.Number
      Case -2147024809
           Resume Exit_Here
      Case Else
           Debug.Print "CreateButton(" & ThisToolBar.Name & "," & strSettings & ")" & vbCrLf & "Error # " & Err.Number, Err.Description
           Resume Exit_Here
 End Select
End Function
Public Function SetToolbar(sName As String) As AcadToolbar
Dim MyToolbar As AcadToolbar
Dim currMenuGroup As AcadMenuGroup
Dim intcnt As Integer
Dim blnFoundTB As Boolean
Dim intNextGroup As Integer
On Error GoTo Err_Control
 For intcnt = 0 To ThisDrawing.Application.MenuGroups.Count - 1
      If ThisDrawing.Application.MenuGroups.Item(intcnt).Name = "ACAD" Then
           Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(intcnt)
           Exit For
      End If
 Next
 'Create new toolbar
 Set MyToolbar = currMenuGroup.Toolbars.Add(sName)
Exit_Here:
 Set SetToolbar = MyToolbar
 Exit Function
 
 
Err_Control:
 Select Case Err.Number
      Case -2147024809 'Toolbar exist
Retry_Different_MenuGroup:
           Debug.Print currMenuGroup.Name
           For intcnt = 0 To currMenuGroup.Toolbars.Count - 1
                If currMenuGroup.Toolbars.Item(intcnt).Name = sName Then
                    Set MyToolbar = currMenuGroup.Toolbars.Item(sName)
                    blnFoundTB = True
                End If
           Next
           If blnFoundTB = False Then
                If intNextGroup  "ACAD" Then
                          Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(intNextGroup)
                          intNextGroup = intNextGroup + 1
                          GoTo Retry_Different_MenuGroup
                     Else
                          intNextGroup = intNextGroup + 1
                          Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(intNextGroup)
                          GoTo Retry_Different_MenuGroup
                     End If
                End If
           End If
           Resume Next
      Case Else
           InputBox Err.Description, "Error", Err.Number
           Resume Exit_Here
 End Select
End Function

Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function User_Name()
Dim sBuffer As String
Dim lSize As Long
'Get User Name
 sBuffer = Space$(255)
 lSize = Len(sBuffer)
 Call GetUserName(sBuffer, lSize)
 If lSize > 0 Then
      User_Name = Left$(sBuffer, lSize)
 Else
      User_Name = vbNullString
 End If
End Function
'//*** "C:\Documents and Settings" & Replace(User_Name, Chr(0), "") & "\Application Data\Autodesk\AutoCAD 2004\R16.0\enu\Support\My_NewCustom_Menu.mnu"
Public Function SaveT(sFiletxt As String, sFilePath As String)
On Error Resume Next
Open sFilePath For Output As #1
Print #1, sFiletxt
Close #1
End Function
Public Function CreateMenu() As Boolean
Dim strFiletxt As String
Dim strTBName As String
Dim varSettings As Variant
Dim intcnt As Integer
Dim strRet As String
Dim strMenuPath As String
strTBName = frmCreateTB.TextBox1.Text
 
strFiletxt = "***MENUGROUP=VBAAPPS" & vbCrLf & vbCrLf
strFiletxt = strFiletxt & "***TOOLBARS" & vbCrLf
strFiletxt = strFiletxt & "**" & strTBName & vbCrLf
'& "ID_" & strTBName & "_0" & vbTab
strFiletxt = strFiletxt & "[_Toolbar(""" & strTBName & """, _Top, _Show, 0, 0, 1)]" & vbCrLf
For intcnt = 0 To frmCreateTB.ListBox2.ListCount - 1
    If FindRecord(frmCreateTB.ListBox2.List(intcnt), strRet) = True Then
            'If objToolbar Is Not Nothing Then
                'CreateButton objToolbar, strRet
            'End If
         '0 = Name
         '1 = Description
         '2 = Macro
         '3 = Icon
         varSettings = Split(strRet, "|")
         '& "ID_" & Replace(varSettings(0), " ", "") & "_0" & vbTab
         strFiletxt = strFiletxt & "[_Button(""" & varSettings(0) & """, """ & varSettings(3) & """, """ & varSettings(3) & """)]" & "_" & varSettings(2) & vbCrLf
   End If
Next
strFiletxt = strFiletxt & vbCrLf
strFiletxt = strFiletxt & "***HELPSTRINGS" & vbCrLf
For intcnt = 0 To frmCreateTB.ListBox2.ListCount - 1
    If FindRecord(frmCreateTB.ListBox2.List(intcnt), strRet) = True Then
         varSettings = Split(strRet, "|")
         strFiletxt = strFiletxt & "ID_" & Replace(varSettings(0), " ", "") & "_0" & vbTab & "[" & varSettings(1) & "]" & vbCrLf
    End If
       
Next
strMenuPath = "C:\Documents and Settings" & Replace(User_Name, Chr(0), "") & "\Application Data\Autodesk\AutoCAD 2004\R16.0\enu\Support\My_NewCustom_Menu.mnu"
SaveT strFiletxt, strMenuPath
    
    If IsMenuLoaded(strMenuPath) = False Then
        MsgBox "Error Loading Menu"
    End If
    
End Function
Public Function IsMenuLoaded(sPath As String) As Boolean
On Error Resume Next
    ThisDrawing.Application.MenuGroups.Load sPath
    
    If Err.Number  0 Then
           IsMenuLoaded = True
           Err.Clear
           'ThisDrawing.Application.MenuGroups.Item.MenuFileName
           
    Else
           IsMenuLoaded = True
    End If
    
    
End Function