Option Compare Database
Option Explicit

' ============================================================
' : mAppShell
'
' :
'    Access- ""  Alpha-.
'
'  XML Ribbon:
'      - :
'       <tabs></tabs>
'
'             .
'    Ribbon-   startFromScratch="true",
'         visible="false".
' ============================================================


Private Const MAIN_FORM_NAME As String = "f"

Private Const HIDDEN_RIBBON_NAME As String = "PivovarHiddenRibbon"
Private Const USYS_RIBBONS_TABLE As String = "USysRibbons"


' ============================================================
'  
' ============================================================

Public Sub ConfigurePivovarAlphaShell()

    On Error GoTo ErrorHandler

    If MsgBox( _
        "  Alpha-?" & vbCrLf & vbCrLf & _
        "   f,    Access " & _
        "    ." & vbCrLf & vbCrLf & _
        "      .", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        " Alpha" _
    ) <> vbYes Then
        Exit Sub
    End If

    Call EnsureHiddenRibbon
    Call SetHiddenRibbonAsStartupRibbon

    Call SetDbProperty("StartupForm", dbText, MAIN_FORM_NAME)
    Call SetDbProperty("AllowFullMenus", dbBoolean, False)
    Call SetDbProperty("AllowShortcutMenus", dbBoolean, False)
    Call SetDbProperty("AllowBuiltInToolbars", dbBoolean, False)
    Call SetDbProperty("AllowToolbarChanges", dbBoolean, False)
    Call SetDbProperty("AllowSpecialKeys", dbBoolean, False)
    Call SetDbProperty("AllowBreakIntoCode", dbBoolean, False)
    Call SetDbProperty("StartupShowDBWindow", dbBoolean, False)
    Call SetDbProperty("StartUpShowDBWindow", dbBoolean, False)

    '       Shift .
    Call SetDbProperty("AllowBypassKey", dbBoolean, True)

    Call HideAccessInterface

    MsgBox " Alpha- ." & vbCrLf & vbCrLf & _
           ": Ribbon-     " & _
           "   .", _
           vbInformation, _
           " Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "    Alpha-." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " Alpha"

End Sub


Public Sub ConfigurePivovarAlphaShellStrict()

    On Error GoTo ErrorHandler

    If MsgBox( _
        "   Alpha?" & vbCrLf & vbCrLf & _
        "     Shift." & vbCrLf & _
        "        ." & vbCrLf & vbCrLf & _
        "?", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        " Alpha" _
    ) <> vbYes Then
        Exit Sub
    End If

    Call EnsureHiddenRibbon
    Call SetHiddenRibbonAsStartupRibbon

    Call SetDbProperty("StartupForm", dbText, MAIN_FORM_NAME)
    Call SetDbProperty("AllowFullMenus", dbBoolean, False)
    Call SetDbProperty("AllowShortcutMenus", dbBoolean, False)
    Call SetDbProperty("AllowBuiltInToolbars", dbBoolean, False)
    Call SetDbProperty("AllowToolbarChanges", dbBoolean, False)
    Call SetDbProperty("AllowSpecialKeys", dbBoolean, False)
    Call SetDbProperty("AllowBreakIntoCode", dbBoolean, False)
    Call SetDbProperty("StartupShowDBWindow", dbBoolean, False)
    Call SetDbProperty("StartUpShowDBWindow", dbBoolean, False)
    Call SetDbProperty("AllowBypassKey", dbBoolean, False)

    Call HideAccessInterface

    MsgBox "  Alpha ." & vbCrLf & vbCrLf & _
           "    .    ACCDE.", _
           vbInformation, _
           " Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "     Alpha." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " Alpha"

End Sub


Public Sub RestorePivovarDeveloperShell()

    On Error GoTo ErrorHandler

    If MsgBox( _
        "   Access?" & vbCrLf & vbCrLf & _
        "   ,  ,   " & _
        "    Shift.", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
        " Alpha" _
    ) <> vbYes Then
        Exit Sub
    End If

    Call DeleteDbProperty("StartupForm")
    Call DeleteDbProperty("CustomRibbonID")

    Call SetDbProperty("AllowFullMenus", dbBoolean, True)
    Call SetDbProperty("AllowShortcutMenus", dbBoolean, True)
    Call SetDbProperty("AllowBuiltInToolbars", dbBoolean, True)
    Call SetDbProperty("AllowToolbarChanges", dbBoolean, True)
    Call SetDbProperty("AllowSpecialKeys", dbBoolean, True)
    Call SetDbProperty("AllowBreakIntoCode", dbBoolean, True)
    Call SetDbProperty("StartupShowDBWindow", dbBoolean, True)
    Call SetDbProperty("StartUpShowDBWindow", dbBoolean, True)
    Call SetDbProperty("AllowBypassKey", dbBoolean, True)

    Call ShowAccessInterface

    MsgBox "  ." & vbCrLf & vbCrLf & _
           "    ,  Ribbon  .", _
           vbInformation, _
           " Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "    ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " Alpha"

End Sub


Public Sub FixHiddenRibbonXmlNow()

    '      USysRibbons.
    '
    ' ,      XML Ribbon.
    '         .

    On Error GoTo ErrorHandler

    Call EnsureHiddenRibbon
    Call SetHiddenRibbonAsStartupRibbon

    MsgBox "XML  Ribbon- ." & vbCrLf & vbCrLf & _
           "     .", _
           vbInformation, _
           " Alpha"

    Exit Sub

ErrorHandler:

    MsgBox "   XML Ribbon." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " Alpha"

End Sub


Public Sub DisableCustomRibbonNow()

    '    Ribbon-.
    '
    ' ,   XML   .
    '       .

    On Error Resume Next

    Call DeleteDbProperty("CustomRibbonID")
    Call ShowAccessInterface

    MsgBox " Ribbon- ." & vbCrLf & vbCrLf & _
           "     .", _
           vbInformation, _
           " Alpha"

End Sub


Public Sub HideAccessInterface()

    On Error Resume Next

    DoCmd.ShowToolbar "Ribbon", acToolbarNo

    CommandBars("Ribbon").Visible = False
    CommandBars("Menu Bar").Enabled = False

    DoCmd.SelectObject acTable, , True
    DoCmd.RunCommand acCmdWindowHide

End Sub


Public Sub ShowAccessInterface()

    On Error Resume Next

    CommandBars("Ribbon").Visible = True
    CommandBars("Menu Bar").Enabled = True

    DoCmd.ShowToolbar "Ribbon", acToolbarYes
    DoCmd.SelectObject acTable, , True

End Sub


Public Sub PreparePivovarAlphaAccdeChecklist()

    MsgBox _
        "   Alpha:" & vbCrLf & vbCrLf & _
        "1.    dev-." & vbCrLf & _
        "2.    :" & vbCrLf & _
        "   - cmdCreateAlphaTrialLicense" & vbCrLf & _
        "   - cmdResetLicense" & vbCrLf & _
        "3.  Tag/  = RequiresLicense   ." & vbCrLf & _
        "4.   -> ." & vbCrLf & _
        "5.   Alpha-." & vbCrLf & _
        "6.     ." & vbCrLf & _
        "7.   f   Ribbon." & vbCrLf & _
        "8.     ." & vbCrLf & _
        "9.        ." & vbCrLf & _
        "10.  ->   ->  ACCDE.", _
        vbInformation, _
        " Alpha"

End Sub


' ============================================================
' USysRibbons /  Ribbon-
' ============================================================

Private Sub EnsureHiddenRibbon()

    On Error GoTo ErrorHandler

    If TableExists(USYS_RIBBONS_TABLE) = False Then
        Call CreateUsysRibbonsTable
    End If

    Call UpsertHiddenRibbonXml

    Exit Sub

ErrorHandler:

    MsgBox "    Ribbon-." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " Alpha"

End Sub


Private Sub CreateUsysRibbonsTable()

    On Error GoTo ErrorHandler

    CurrentDb.Execute _
        "CREATE TABLE [" & USYS_RIBBONS_TABLE & "] (" & _
        "[ID] AUTOINCREMENT CONSTRAINT [PrimaryKey] PRIMARY KEY, " & _
        "[RibbonName] TEXT(255), " & _
        "[RibbonXml] LONGTEXT" & _
        ");", _
        dbFailOnError

    CurrentDb.Execute _
        "CREATE UNIQUE INDEX [ux_USysRibbons_RibbonName] " & _
        "ON [" & USYS_RIBBONS_TABLE & "] ([RibbonName]);", _
        dbFailOnError

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub UpsertHiddenRibbonXml()

    On Error GoTo ErrorHandler

    Dim ribbonXml As String
    Dim existingCount As Long

    ribbonXml = GetHiddenRibbonXml()
    existingCount = DCount("*", USYS_RIBBONS_TABLE, "[RibbonName] = " & SqlText(HIDDEN_RIBBON_NAME))

    If existingCount = 0 Then

        CurrentDb.Execute _
            "INSERT INTO [" & USYS_RIBBONS_TABLE & "] ([RibbonName], [RibbonXml]) " & _
            "VALUES (" & SqlText(HIDDEN_RIBBON_NAME) & ", " & SqlText(ribbonXml) & ");", _
            dbFailOnError

    Else

        CurrentDb.Execute _
            "UPDATE [" & USYS_RIBBONS_TABLE & "] SET [RibbonXml] = " & SqlText(ribbonXml) & " " & _
            "WHERE [RibbonName] = " & SqlText(HIDDEN_RIBBON_NAME) & ";", _
            dbFailOnError

    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function GetHiddenRibbonXml() As String

    '   Ribbon-.
    '
    ' :
    '      <tabs></tabs>.
    '    tabs  tab, tab  group, group  button.
    '       visible="false".
    '
    ' startFromScratch="true"    Ribbon.

    GetHiddenRibbonXml = _
        "<customUI xmlns=""http://schemas.microsoft.com/office/2006/01/customui"">" & _
        "  <ribbon startFromScratch=""true"">" & _
        "    <tabs>" & _
        "      <tab id=""tabPivovarHidden"" label="""" visible=""false"">" & _
        "        <group id=""grpPivovarHidden"" label="""" visible=""false"">" & _
        "          <button id=""btnPivovarHidden"" label="""" visible=""false"" />" & _
        "        </group>" & _
        "      </tab>" & _
        "    </tabs>" & _
        "  </ribbon>" & _
        "</customUI>"

End Function


Private Sub SetHiddenRibbonAsStartupRibbon()

    Call SetDbProperty("CustomRibbonID", dbText, HIDDEN_RIBBON_NAME)

End Sub


' ============================================================
'  
' ============================================================

Private Sub SetDbProperty( _
    ByVal propertyName As String, _
    ByVal propertyType As DAO.DataTypeEnum, _
    ByVal propertyValue As Variant _
)

    On Error GoTo ErrorHandler

    If propertyType = dbText Then

        If IsNull(propertyValue) Or Len(CStr(propertyValue)) = 0 Then
            Call DeleteDbProperty(propertyName)
            Exit Sub
        End If

    End If

    If DbPropertyExists(propertyName) = True Then

        CurrentDb.Properties(propertyName).value = propertyValue

    Else

        Dim prp As DAO.Property

        Set prp = CurrentDb.CreateProperty(propertyName, propertyType, propertyValue)
        CurrentDb.Properties.Append prp

    End If

    Exit Sub

ErrorHandler:

    Debug.Print "    :", propertyName, Err.Description

End Sub


Private Sub DeleteDbProperty(ByVal propertyName As String)

    On Error Resume Next

    If DbPropertyExists(propertyName) Then
        CurrentDb.Properties.Delete propertyName
    End If

End Sub


Private Function DbPropertyExists(ByVal propertyName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim valueHolder As Variant

    valueHolder = CurrentDb.Properties(propertyName).value

    DbPropertyExists = True

    Exit Function

ErrorHandler:

    DbPropertyExists = False

End Function


Private Function TableExists(ByVal tableName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim tdf As DAO.TableDef

    For Each tdf In CurrentDb.TableDefs

        If StrComp(tdf.Name, tableName, vbTextCompare) = 0 Then
            TableExists = True
            Exit Function
        End If

    Next tdf

    TableExists = False

    Exit Function

ErrorHandler:

    TableExists = False

End Function


Private Function SqlText(ByVal sourceValue As Variant) As String

    If IsNull(sourceValue) Then
        SqlText = "Null"
    Else
        SqlText = "'" & Replace(CStr(sourceValue), "'", "''") & "'"
    End If

End Function