Acad 工具栏和按钮
我在使用数据库和VBA创建工具栏和按钮时遇到了问题。每次我退出AutoCad时，此工具栏上的按钮都会丢失，并且工具栏会被关闭，但仍然可以在工具栏菜单中找到该工具栏。基本上，当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 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
**** Hidden Message ***** 只是想澄清一下，你在追求什么/你想让工具栏保持原样，还是在按钮按下时让工具栏消失？ 是的，我需要在acad重新打开后，工具栏和按钮保持不变 唯一的问题是，当AutoCad重新打开时，按钮将从工具栏中删除，并且必须通过运行宏来创建工具栏来再次添加。 看起来您没有将更改保存到菜单文件中。
http://discussion.autodesk.com/forums/thread.jspa?messageID=3555168� 好的！所以我决定改变我的方法！我已经创建了包含工具栏和按钮的. mnu文件。菜单保存得很好，工具栏也一样，但是由于某种原因，按钮在acad重新启动后不会像以前一样停留。
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
工具栏不在当前工作区中？ ？？？ 您使用的是什么版本？ AutoCAD 2004香草
页:
[1]
2