Ленты (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