Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | WinAPI


Rambler's Top100


Counter CO.KZ


Комментарий : Все приведённые примеры актуальны только для 32-bit. Обладателям же 64-bit, необходимо изменить об'явления WinAPI функций. Сделать это поможет статья, опубликованная на официальном сайте Microsoft Совместимость 32- и 64-разрядных версий Office 2010 и файл Win32API_PtrSafe.txt, который можно скачать там же.



    [0] [1] [2] [3]

  1. Как воспроизвести небольшой "анимационный ролик" (WinAPI) ? 28.08.2009
  2. Как программно перенести фокус ввода в строку формул ? 27.06.2010
  3. Как создать текстовое поле на панели инструментов, которое, по мере ввода символов, будет выдавать список имён файлов, папок и/или URL адресов, начинающихся с введённых символов ? 08.04.2011
  4. Как программно изменить ширину выпадающего списка - поля со списком Имя (расположенное слева от строки формул) ? 09.06.2010
  5. Как заблокировать поле со списком Имя (расположенное слева от строки формул) ? 04.08.2007
  6. Как запретить ввод данных в поле со списком Имя ? 04.08.2007
  7. Как программно отобразить список имён ? 17.05.2008
  8. Как программно отобразить список элемента управления ImageComboBox ? 03.08.2008
  9. Как программно изменить ширину выпадающего списка в ImageComboBox ? 03.08.2008
  10. Как программно изменить цвет ProgressBar ? 01.09.2009
  11. Как добавить сетку, флажки, выделение всей строки и т.д. в Microsoft ListView Control version 5 ? 11.02.2012
  12. Как сделать так, чтобы в списке файлов в ListView, отображались иконки этих файлов ? 22.05.2014
  13. Как установить автоподбор ширины для всех столбцов в ListView ? 24.01.2016
  14. Как определить запущен или нет Microsoft Word, а также, при необходимости, получить доступ к этому об'екту ? 30.03.2012
  15. Как создать диалоговое окно "О программе" ? 14.04.2011
    [0] [1] [2] [3]


  • Ответ : Скачать пример

    Возможно Вы замечали, что во время выполнения некоторых операций, к примеру, копирование/удаление файлов, папок можно наблюдать некоторые анимационные эффекты, такие как перемещающиеся из одной папки в другую бумаги, выбрасываемые в мусорную корзину скомканные листы и т.п. Если такие же анимационные ролики Вам необходимо демонстрировать на своём нестандартном диалоговом окне, то воспользуйтесь элементом управления Microsoft Animation Control
    Если же его нет в списке доступных элементов управления, например, в случае отсутствия на компьютере файла MSComct2.ocx или Comct232.ocx, то осуществить задуманное можно с помощью соответствующих функций WinAPI, естественно, указав нужное месторасположение окна, размеры и полное имя avi файла :
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function CreateWindowEx _
            Lib "user32.dll" Alias "CreateWindowExA" ( _
            ByVal dwExStyle As Long, _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String, _
            ByVal dwStyle As Long, _
            ByVal X As Long, _
            ByVal Y As Long, _
            ByVal nWidth As Long, _
            ByVal nHeight As Long, _
            ByVal hWndParent As Long, _
            ByVal hMenu As Long, _
            ByVal hInstance As Long, _
            lpParam As Any) As Long
    Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long
    Private Declare Function DestroyWindow _
            Lib "user32.dll" (ByVal hWnd As Long) As Long
    
    Private ihChildWnd As Long
    
    Private Sub UserForm_Initialize()
        Dim ihWnd As Long
        ihWnd = FindWindow(vbNullString, Me.Caption)
        ihChildWnd = CreateWindowEx(0&, "SysAnimate32", "SAn", _
        1342177286&, 0&, 0&, 100&, 50&, ihWnd, 0&, 0&, ByVal 0&)
    End Sub
    
    Private Sub CommandButton1_Click() 'Старт
        SendMessage ihChildWnd, 1124&, 0&, ByVal "C:\Мои_файлы\clock.avi"
    End Sub
    
    Private Sub CommandButton2_Click() 'Стоп
        SendMessage ihChildWnd, 1126&, 1&, ByVal 0&
    End Sub
    
    Private Sub UserForm_Terminate()
        DestroyWindow ihChildWnd
    End Sub

  • Ответ :

    Если в процессе работы Вы часто используете строку формул и Вы хотите "выделять" её с помощью горячих клавиш, то найдите/создайте личную книгу макросов "Personal.xls" Затем скопируйте нижеопубликованный код в любой стандартный модуль этой книги, после чего в меню Сервис выберите пункт Макрос и команду Макросы или нажмите сочетание клавиш ALT + F8. В появившемся стандартном диалоговом окне Макрос выберите PERSONAL.xls!SetFocus_FormulaBar и кликните кнопку Параметры, во втором диалоговом окне Параметры макроса в небольшом текстовом поле, расположенном сразу после надписи Ctrl+ введите r и кликните кнопки OK и Закрыть/Отмена.

    Если сочетание клавиш Ctrl+r Вас не устраивает, то используя этот совет [FAQ95] можно назначить созданному макросу и другие горячие клавиши.
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpsz1 As String, _
            ByVal lpsz2 As String) As Long
    Private Declare Function SetFocus _
            Lib "user32.dll" ( _
            ByVal hWnd As Long) As Long
    
    Public Sub SetFocus_FormulaBar()
    '
    ' SetFocus_FormulaBar Макрос
    ' Макрос записан 27.06.2010 (Климов П.Ю.)
    '
    ' Сочетание клавиш: Ctrl+r
    '
        ihWnd& = FindWindow("XLMAIN", Application.Caption)
        ihWnd& = FindWindowEx(ihWnd&, 0&, "EXCEL<", vbNullString)
        SetFocus ihWnd&
    End Sub

  • Ответ :

    Если на панели инструментов необходимо создать текстовое поле, которое, по мере ввода символов, будет выдавать список имён файлов, папок и/или URL адресов, начинающихся с введённых символов, примерно так, как это реализована в интернет-браузерах, то используйте нижеопубликованный макрос.
  • Private Const SHACF_DEFAULT = &H0
    Private Const SHACF_FILESYSTEM = &H1
    Private Const SHACF_URLMRU = &H4
    Private Const SHACF_URLHISTORY = &H2
    Private Const SHACF_URLALL = SHACF_URLHISTORY Or SHACF_URLMRU
    
    Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpSz1 As String, _
            ByVal lpSz2 As String) As Long
    Private Declare Function SHAutoComplete _
            Lib "Shlwapi.dll" ( _
            ByVal hWndEdit As Long, _
            ByVal dwFlags As Long) As Long
    
    Private Sub CreateAutoCompleteEditBox()
        With Application.CommandBars.Add(Temporary:=True)
             .Left = 0: .Protection = msoBarNoChangeDock
             With .Controls.Add(Type:=msoControlEdit)
                  .Width = 600
                  .Caption = "Поле для ввода :"
                  .Style = msoButtonIcon
                  '.Text = "Введите текст"
                  '.OnAction = "Макрос1"
             End With
             .Visible = True
             
             If Val(Application.Version) = 8 Then
                iClassName$ = "Edit"        'XL97
             Else
                iClassName$ = "RichEdit20W" 'XL2002
             End If
             Application.Wait DateAdd("S", 1, Now) 'DoEvents
         
             ihWnd& = FindWindow("MsoCommandBar", .NameLocal)
             ihWnd& = FindWindowEx(ihWnd&, 0&, iClassName$, vbNullString)
             SHAutoComplete ihWnd&, SHACF_DEFAULT
        End With
    End Sub
    Комментарий :
  • Использование свойств Left, Protection не является обязательным.
  • Допускается создание новой панели инструментов с конкретным именем (см. необязательный именованный аргумент Name метода Add, либо свойство Name об'екта CommandBar) Однако, это имя должно быть уникально, проще говоря, в семействе CommandBars не должно быть панели с таким именем, в противном случае, Вы получите ошибку.
  • Если Вы хотите, чтобы в текстовом поле появлялся список только из файлов и папок, то замените константу SHACF_DEFAULT на SHACF_FILESYSTEM
  • Если же Вы хотите закрепить панель инструментов, например, сверху или снизу, то используйте второй варинт, где в качестве бонуса, добавлена ещё и кнопка.
  • Обратите внимание на то, что имя класса может меняться, в зависимости от версии приложения, поэтому, для работоспособности данного примера, имеет смысл либо определить номер используемой версии (вариант I), либо отказаться от явного указания класса (вариант II)
  • Private Const SHACF_DEFAULT = &H0
    Private Const SHACF_FILESYSTEM = &H1
    Private Const SHACF_URLMRU = &H4
    Private Const SHACF_URLHISTORY = &H2
    Private Const SHACF_URLALL = SHACF_URLHISTORY Or SHACF_URLMRU
    
    Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpSz1 As String, _
            ByVal lpSz2 As String) As Long
    Private Declare Function SHAutoComplete _
            Lib "Shlwapi.dll" ( _
            ByVal hWndEdit As Long, _
            ByVal dwFlags As Long) As Long
            
    Private Sub CreateAutoCompleteEditBox2()
        Dim ihWnd As Long, iLocalBarName As String
        
        With Application.CommandBars.Add(Temporary:=True)
             .Position = msoBarTop 'msoBarBottom
             With .Controls.Add(Type:=msoControlEdit)
                  .Width = 500
                  .Caption = "Поле для ввода :"
                  .Style = msoButtonIcon
                  '.Text = "Введите текст"
                  '.OnAction = "Макрос1"
             End With
             With .Controls.Add(Type:=msoControlButton)
                  .Width = 50
                  .Caption = "Открыть"
                  .Style = msoButtonCaption
                  '.OnAction = "Макрос2"
             End With
             .Visible = True: iLocalBarName = .NameLocal
        End With              
        DoEvents 'Application.Wait DateAdd("S", 1, Now)
        
        ihWnd = FindWindow("XLMAIN", Application.Caption)
        ihWnd = FindWindowEx(ihWnd, 0&, "EXCEL2", vbNullString)
        ihWnd = FindWindowEx(ihWnd, 0&, "MsoCommandBar", iLocalBarName)
        ihWnd = FindWindowEx(ihWnd, 0&, vbNullString, vbNullString)
        SHAutoComplete ihWnd, SHACF_FILESYSTEM 'SHACF_DEFAULT
    End Sub

  • Ответ :

    Если в процессе работы Вы используете имена ячеек/диапазонов, то, возможно, знаете, что имя может содержать до 255 (включительно) символов, тогда как ширина выдающего списка (поле со списком Имя, расположенное слево от строки формул), относительна невелика и позволяет увидеть не более 10-25 символов. И если такое количество отображаемых символов Вас не устраивает, то просто найдите/создайте личную книгу макросов "Personal.xls" и скопируйте в модуль книги ThisWorkbook(ЭтаКнига) нижеопубликованный код (500 это требуемая ширина выдающего списка и она может быть изменена)
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpSz1 As String, _
            ByVal lpSz2 As String) As Long
    Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long
            
    Private Sub Workbook_Open()
        Dim ihWnd As Long
    
        ihWnd = FindWindow("XLMAIN", Application.Caption)
        ihWnd = FindWindowEx(ihWnd, 0&, "EXCEL;", vbNullString)
        ihWnd = FindWindowEx(ihWnd, 0&, "COMBOBOX", vbNullString)
    
        SendMessage ihWnd, 352&, 500&, ByVal 0&
    End Sub

  • Ответ :

    Если Вам необходимо запретить использование поля со списком Имя, которое расположено слево от строки формул, то для этого достаточно выполнить нижеприведённый макрос.
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpSz1 As String, _
            ByVal lpSz2 As String) As Long
    Private Declare Function EnableWindow _
            Lib "user32.dll" ( _
            ByVal hWnd As Long, _
            ByVal fEnable As Long) As Long

    Private Sub Disabled_ComboName()
        Dim ihWnd As Long

        ihWnd = FindWindow("XLMAIN", Application.Caption)
        ihWnd = FindWindowEx(ihWnd, 0&, "EXCEL;", vbNullString)

        EnableWindow ihWnd, 0& '1& = Enabled
    End Sub

  • Ответ :

    Для того, чтобы заблокировать ввод данных в поле Имя, т.е. запретить создание новых имён и переход к нужной ячейке или диапазону, посредством ввода адреса, сохранив при этом возможность выбора уже имеющихся имён, достаточно выполнить нижеприведённый макрос.
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpSz1 As String, _
            ByVal lpSz2 As String) As Long
    Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub ReadOnly_ComboName()
        Dim ihWnd As Long

        ihWnd = FindWindow("XLMAIN", Application.Caption)
        ihWnd = FindWindowEx(ihWnd, 0&, "EXCEL;", vbNullString)
        ihWnd = FindWindowEx(ihWnd, 0&, "COMBOBOX", vbNullString)
        ihWnd = FindWindowEx(ihWnd, 0&, "EDIT", vbNullString)

        SendMessage ihWnd, 207&, 0&, ByVal 0&
    End Sub
    Комментарий : Обратите внимание на то, что для создания нового имени [FAQ] можно использовать и другие возможности Excel, равно как и для перехода к указанной ячейке [FAQ]
  • Ответ :

    Для того, чтобы программно отобразить выпадающий список, содержащий перечень именованных ячеек, диапазонов, достаточно выполнить нижеприведённый макрос.
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx _
            Lib "user32.dll" Alias "FindWindowExA" ( _
            ByVal hWnd1 As Long, _
            ByVal hWnd2 As Long, _
            ByVal lpSz1 As String, _
            ByVal lpSz2 As String) As Long
    Private Declare Function SetFocus _
            Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub DropDown_ComboBoxName()
        Dim ihWnd As Long

        ihWnd = FindWindow("XLMAIN", Application.Caption)
        ihWnd = FindWindowEx(ihWnd, 0&, "EXCEL;", vbNullString)
        ihWnd = FindWindowEx(ihWnd, 0&, "COMBOBOX", vbNullString)

        SetFocus ihWnd: SendMessage ihWnd, 335&, 1&, ByVal 0&
    End Sub

  • Ответ :

    Для того, чтобы программно отобразить выпадающий список элемента управления ImageComboBox, достаточно выполнить нижеприведённый макрос (где ImageCombo1 это имя используемого контрола)
  • Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub DropDown_ImageComboBox()
        SendMessage ImageCombo1.hWnd, 335&, 1&, ByVal 0&
    End Sub

  • Ответ :

    Для того, чтобы программно изменить ширину выпадающего списка элемента управления ImageComboBox, достаточно выполнить нижеприведённый макрос (где ImageCombo1 это имя используемого контрола, а 400 это требуемая ширина)
  • Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub DropDownWidth_ImageComboBox()
        SendMessage ImageCombo1.hWnd, 352&, 400&, ByVal 0&
    End Sub

  • Ответ : Скачать пример

    Если Вы решили создать собственный Прогресс Бар, то проблем с изменением цвета полоски возникнуть не должно. Если же Вы выбрали Microsoft ProgressBar Control, то имейте ввиду, что этот элемент управления не имеет свойства, отвечающего за выбор нужного цвета. Впрочем, несмотря на это, изменить цвет всё-таки можно и для этого достаточно выполнить нижеприведённый макрос, указав нужный цвет : либо с помощью константы, либо с помощью VB функции RGB(Red, Green, Blue)
  • Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub SetBarColor_ProgressBar()
        SendMessage ProgressBar1.hWnd, 1033&, 1&, ByVal vbRed '255 'RGB(255, 0, 0)
    End Sub

  • Ответ :

    Если Вы используете Microsoft ListView Control version 5 и хотите добавить сетку, флажки, подсветку и выделение всей строки, а также плоскую полосу прокрутки, то используйте нижеопубликованный код, где создание расширенного стиля расписано довольно подробно и Вам не составит труда оставить только нужные стили. Обратите внимание на то, что большинство LVS_EX имеет смысл использовать только вкупе со стилем LVS_REPORT, который, в данном примере, устанавливается с помощью свойства .View и, разумеется, заполнение ListView осуществляется исключительно для демонстрации.
  • Private Const LVS_EX_CHECKBOXES As Long = &H4
    Private Const LVS_EX_FLATSB As Long = &H100
    Private Const LVS_EX_FULLROWSELECT As Long = &H20
    Private Const LVS_EX_GRIDLINES As Long = &H1
    Private Const LVS_EX_TRACKSELECT As Long = &H8
    Private Const LVS_EX_ONECLICKACTIVATE As Long = &H40
    Private Const LVS_EX_TWOCLICKACTIVATE As Long = &H80
    Private Const LVS_EX_UNDERLINECOLD As Long = &H1000
    Private Const LVS_EX_UNDERLINEHOT As Long = &H800

    Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_GETEXTENDEDLISTVIEWSTYLE As Long = (LVM_FIRST + 55)
    Private Const LVM_SETEXTENDEDLISTVIEWSTYLE As Long = (LVM_FIRST + 54)

    Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub UserForm_Initialize()
        Dim ihWnd&, iStyle&, iCount%

        ihWnd = ListView1.hWnd

        iStyle = SendMessage(ihWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, ByVal 0&)
        iStyle = iStyle Or LVS_EX_CHECKBOXES 'CheckBoxes
        iStyle = iStyle Or LVS_EX_GRIDLINES 'GridLines
        iStyle = iStyle Or LVS_EX_FULLROWSELECT 'FullRowSelect
        iStyle = iStyle Or LVS_EX_TRACKSELECT 'HotTracking
        'iStyle = iStyle Or LVS_EX_FLATSB 'FlatScrollBar
        'iStyle = iStyle Or LVS_EX_UNDERLINECOLD Or LVS_EX_TWOCLICKACTIVATE
        'iStyle = iStyle Or LVS_EX_UNDERLINEHOT Or LVS_EX_ONECLICKACTIVATE Or LVS_EX_TWOCLICKACTIVATE

        SendMessage ihWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, ByVal iStyle

        For iCount = 1 To 100
            ListView1.ListItems.Add , , "Текст" & iCount
        Next

        ListView1.View = lvwReport
        ListView1.ColumnHeaders.Add
    End Sub
    Примечание : Если необходимо только "добавить" сетку, то Вы можете также воспользоваться следующим советом - VB Как нарисовать сетку в ListView

    Комментарий : Если же Вы используете контрол version 6, то в применение WinAPI нет особой необходимости, ибо в шестой версии появились соответствующие свойства (см. комментарии напротив стилей)
  • Ответ :
  • Private Const LVM_FIRST As Long = &H1000
    Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
    Private Const LVSCW_AUTOSIZE As Long = -1

    Private Declare Function SendMessage _
            Lib "user32.dll" Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

    Private Sub ListView_AutoFit()
        Dim iColumn&
        For iColumn = 0 To ListView1.ColumnHeaders.Count - 1
            SendMessage ListView1.hWnd, LVM_SETCOLUMNWIDTH, iColumn, LVSCW_AUTOSIZE
        Next
    End Sub

  • Ответ :
  • Private Declare Function FindWindow _
            Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long

    Private Sub WinAPI_WordActivate()
        Dim objWord As Object

        If FindWindow("OpusApp", vbNullString) = 0 Then
           Set objWord = CreateObject("Word.Application")
           objWord.Documents.Add
           objWord.Visible = True 'необязательно
        Else
           Set objWord = GetObject(, "Word.Application")
        End If
        'Здесь Вы можете "мучить" objWord
    End Sub

  • Ответ :

    Если Вы решили создать небольшое окно с кратким описанием своей программы, то для этого можно использовать функцию MsgBox или нестандартное диалоговое окно UserForm или DialogSheet. Но можно воспользоваться и стандартным окном от Windows, которое можно увидеть, если в Explorer (и не только) в меню Справка выбрать команду О программе.
  • Private Declare Function ShellAbout _
            Lib "shell32.dll" Alias "ShellAboutA" ( _
            ByVal hWnd As Long, _
            ByVal szApp As String, _
            ByVal szOtherStuff As String, _
            ByVal hIcon As Long) As Long

    Private Sub ShowAboutProgram()
        ShellAbout 0&, _
        "Подсчёт баранов", vbNewLine & _
        "Количество баранов весящих 50 кг.", 0&
    End Sub
    Обратите внимание на то, что данная функция позволяет также создать и значок (иконку), причём не только стандартную.
    Private Declare Function ShellAbout _
            Lib "shell32.dll" Alias "ShellAboutA" ( _
            ByVal hWnd As Long, _
            ByVal szApp As String, _
            ByVal szOtherStuff As String, _
            ByVal hIcon As Long) As Long
    Private Declare Function LoadIcon _
            Lib "user32.dll" Alias "LoadIconA" ( _
            ByVal hInstance As Long, _
            ByVal lpIconName As Long) As Long

    Private Sub ShowAboutProgram2()
        ShellAbout 0&, "Кто хочет стать миллионером", _
        "Викторина для эрудитов и ...", LoadIcon(0&, 32514&)
    End Sub
    Private Declare Function ShellAbout _
            Lib "shell32.dll" Alias "ShellAboutA" ( _
            ByVal hWnd As Long, _
            ByVal szApp As String, _
            ByVal szOtherStuff As String, _
            ByVal hIcon As Long) As Long
    Private Declare Function ExtractIcon _
            Lib "shell32.dll" Alias "ExtractIconA" ( _
            ByVal hInst As Long, _
            ByVal lpszExeFileName As String, _
            ByVal nIconIndex As Long) As Long

    Private Sub ShowAboutProgram3()
        Dim iFile As String, ihIcon As Long

        'iFile = "C:\Windows\System32\Calc.exe"
        iFile = Application.Path & "\Excel.exe"
        ihIcon = ExtractIcon(0&, iFile, 0&)

        ShellAbout 0&, _
        "Калькулятор для бухгалтера", vbNewLine & _
        "Лучшие счёты и абак для бухгалтерии", ihIcon
    End Sub

    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

    © 2004-2017 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff