TopPicLogo TopPicText

Ленты (Ribbons) - Сворачивание - Разворачивание панели лент (MSA 2007 и Выше)


'--------------------------------------------------------------------
' Module    : modRibbonState
' Author    : Sascha Trowitzsch:
'           : https://mvp.support.microsoft.com/profile/Sascha.Trowitzsch
' Date      : ??.??.????
' Purpose   : Ленты (Ribbons)
'           : - Сворачивание | Разворачивание панели лент (MSA 2007 & Up)
'--------------------------------------------------------------------
' es : 18.01.2013
' Немного подправил под свои нужды, и добавил функцию IsMSAver2007AndUp()
' т.к. перед использованием ЭТОГО - не вредно проверить тек. версию MSA
'--------------------------------------------------------------------
Option Compare Database
Option Explicit

' Code: Sascha Trowitzsch: https://mvp.support.microsoft.com/profile/Sascha.Trowitzsch

Private Declare Function SetForegroundWindow Lib "user32.dll" ( _
                 ByVal hWnd As Long) As Long
                 
Private Declare Function SetActiveWindow Lib "user32.dll" ( _
                 ByVal hWnd As Long) As Long
                 
Private Declare Function apiSetFocus Lib "user32.dll" Alias "SetFocus" ( _
                ByVal hWnd As Long) As Long

                 
'Status des Ribbon; Result: 0=normal, -1=minimiert
Private Function RibbonState() As Long
    RibbonState = (CommandBars("Ribbon").Controls(1).Height < 100)
End Function

Public Function MaximizeRibbon(Optional TimeOut As Long = 2) As Boolean
    Dim T As Single

    MaximizeRibbon = True
    If RibbonState = 0 Then Exit Function

    T = Timer()
    'Exit from loop if ribbon is finally maximized
    ' or we have a timeout of 2 seconds - this seems to be sufficient.
   '(Cause: Ribbon does not always react on SendKeys)
    Do While (RibbonState = -1) And (Timer - T) < TimeOut
        SetForegroundWindow Application.hWndAccessApp
        SetActiveWindow Application.hWndAccessApp
        apiSetFocus Application.hWndAccessApp
        SendKeys "^{F1}"    'Ctrl+F1
        'SendKeysAPI "{^F1}"
        DoEvents
    Loop

    MaximizeRibbon = (Timer - T) < TimeOut

End Function

Public Function MinimizeRibbon(Optional TimeOut As Long = 2) As Boolean
    Dim T As Single
    
    MinimizeRibbon = True
    If RibbonState = -1 Then Exit Function

    T = Timer()
    Do While (RibbonState = 0) And (Timer - T) < TimeOut
        SetForegroundWindow Application.hWndAccessApp
        SetActiveWindow Application.hWndAccessApp
        apiSetFocus Application.hWndAccessApp
        SendKeys "^{F1}"    'Ctrl+F1
        'SendKeysAPI "{^F1}"
        DoEvents
    Loop

    MinimizeRibbon = (Timer - T) < TimeOut

End Function

Public Function IsMSAver2007AndUp() As Boolean
Dim iAppVer As Currency
' Проверка версии MS Access
' es - 18.01.2013
' Функция вернёт TRUE если текущая версия MS Access больше 2003
' т.е. есть новые своиства. Конкретно: Ленты (Ribbons)
'--------------------------------------------------------------------
On Error GoTo IsMSAver2007AndUp_Err
    iAppVer = CCur(Mid(Application.Version, 1, 2)) 'Версия MS Access
    
    If iAppVer > 11 Then 'Версия MS Access 2007 и выше (не 2003)
        IsMSAver2007AndUp = True
    End If

IsMSAver2007AndUp_Bye:
    Exit Function

IsMSAver2007AndUp_Err:
    'MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure IsMSAver2007AndUp", vbCritical, "Error!"
    IsMSAver2007AndUp = False
    Resume IsMSAver2007AndUp_Bye
End Function


Назад ToTop
L.E. 20.05.2016
Рейтинг@Mail.ru