Sub Example_SetBitmaps()
    'Этот пример использует MenuGroups, чтобы получить справочник главного меню AutoCADа.
    'Затем создает новую Панель инструментов (TestMenu) и вставляет 
    'ToolBarButton с выбранным значком. Меню автоматически показывают.
    '
    '* ПРИМЕЧАНИЕ: Значки для новой панели инструментов должны
    ' быть перед выполнением этого примера.
        
    Dim currMenuGroup As acadMenuGroup
    Dim newToolBar As AcadToolbar, newToolBarButton As AcadToolbarItem
    Dim openMacro As String
    Dim SmallBitmapName  As String, LargeBitmapName  As String
    
    On Error GoTo ERRORTRAP
    
    'Используйте свойство MenuGroups, чтобы получить справочник главного меню AutoCAD
    Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item("ACAD")
    
    'Создайте новую Панель инструментов в этой группе
    Set newToolBar = currMenuGroup.Toolbars.Add("TestMenu")
    
    'Добавьте элемент к новой Панели инструментов и назначьте макрокоманду Open
    '(VBA эквивалент: "ESC ESC _open")
    openMacro = Chr(3) & Chr(3) & Chr(95) & "open" & Chr(32)
    Set newToolBarButton = newToolBar.AddToolbarButton(newToolBar.count + 1, "Open", "Open Macro", openMacro, False)
   
    'Читайте пути значка для этой Кнопки панели
    GoSub READPATHS
    
    'Измените значок значения по умолчанию для новой кнопки панели
    SmallBitmapName = "c:\images\16x16.bmp"     ' Use a 16x16 pixel .BMP image
    LargeBitmapName = "c:\images\32x32.bmp"     ' Use a 32x32 pixel .BMP image
    newToolBarButton.SetBitmaps SmallBitmapName, LargeBitmapName
    
    'Читайте пути значка для этой Кнопки панели
    GoSub READPATHS
    
    Exit Sub
    
READPATHS:
    'Читайте пути значка для этой Кнопки панели
    newToolBarButton.GetBitmaps SmallBitmapName, LargeBitmapName
    MsgBox "Новая Панель инструментов использует следующие файлы значков: " & _
           vbCrLf & vbCrLf & "Маленький Точечный рисунок: " & SmallBitmapName & vbCrLf & _
           "Большой Точечный рисунок: " & LargeBitmapName
    Return

ERRORTRAP:
    MsgBox "Произошла ошибка: " & Err.Description
End Sub

Сайт управляется системой uCoz