社区 › VB › Acad工具栏和按钮

Matt__W 发表于 2009-6-9 10:52:39

Acad工具栏和按钮

我使用数据库和VBA创建的工具栏和按钮有问题&nbsp；每次退出AutoCad时，此工具栏上的按钮都会丢失，工具栏也会关闭，但工具栏仍可以在工具栏菜单中找到&nbsp；基本上，当Acad关闭时，它会删除按钮，但不会删除工具栏。那么，有什么办法阻止这种情况发生呢&nbsp&nbsp&nbsp&nbsp
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 BitmapNameAs String
Dim SmallBitmapNameAs 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

Matt__W 发表于 2009-6-9 10:58:08

我只是想澄清一下，你在追求什么；当按钮按下时，您是希望工具栏保持完整，还是希望工具栏消失？

Matt__W 发表于 2009-6-9 11:14:55

是的，在acad重新打开后，我需要工具栏与按钮保持完整

Matt__W 发表于 2009-6-9 16:36:54

唯一的问题是，当AutoCad重新打开时，按钮从工具栏中删除，必须通过运行宏来创建工具栏来再次添加&nbsp；

Matt__W 发表于 2009-6-9 16:58:53

它不#039；t看起来像你&#039；重新保存对菜单文件的更改http://discussion.autodesk.com/forums/thread.jspa?messageID=3555168&#3555168

Matt__W 发表于 2009-6-24 12:22:02

好啊所以我决定改变我的方法&nbsp；我已经创建了带有工具栏和按钮的on.mnu文件&nbsp；菜单保存得很好，工具栏也可以，但由于某种原因，acad重新启动后，按钮不会像以前一样保留&nbsp
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 & "" & 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 & "" & "_" & 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.Number0 Then
         IsMenuLoaded = True
         Err.Clear
         'ThisDrawing.Application.MenuGroups.Item.MenuFileName
         
    Else
         IsMenuLoaded = True
    End If
   
   
End Function

Matt__W 发表于 2009-6-24 13:10:28

工具栏是&#039；t在当前工作区中&nbsp&nbsp；

Matt__W 发表于 2009-6-24 14:07:23

? ??

Matt__W 发表于 2009-6-24 15:16:25

你用的是什么版本？

Matt__W 发表于 2009-6-24 16:32:24

AutoCAD 2004 vanilla

查看完整版本: Acad工具栏和按钮