Делимся наработками

Private Function CloseAllOpenModules()
    On Error GoTo Err_
    
    Dim oModules As Modules
    Dim LCount As Long
 
    Set oModules = Application.Modules
    LCount = oModules.Count
    For LCount = oModules.Count - 1 To 0 Step -1
        DoCmd.Close acModule, oModules(LCount).Name, acSaveYes
    Next LCount
    
    Set oModules = Nothing
    
Exit_:
    Exit Function
Err_:
    Resume Next
End Function

'Создаем движок
Set Engine = New SQLiteEngine
 
'Открываем пустую БД в памяти. Можно открыть и физическую
Set SQLite_Connection = Engine.OpenDataBase(":memory:")
 
'Добавляем возможность подключать виртуальные таблицы из Access
SQLite_Connection.AttachAccessDB CurrentDb(), ""
 
'Для того что бы можно было работать с таблицами нужно создать их виртуальную копию
SQLite_Connection.Execute "Create virtual table if not exists MyTable using Access(MyTable)"
 
'Дальше можно открывать набор данных, который по составу методов похож на обычный Recordset
Set SQLite_Recorset = SQLite_Connection.OpenRecordset("select * from MyTable", 0)
If Not SQLite_Recorset.EOF Then
  Debug.Print "Name = [" & SQLite_Recorset.Fields(0).Name & "] Value = [" & SQLite_Recorset.Fields(0).Value & "]"
End If
SQLite_Recorset.Close
Set SQLite_Recorset = Nothing
 
'для удаления таблиц используйте команду 
SQLite_Connection.Execute "drop table if exists MyTable"
 
'Хорошим тоном является все закрыть за собой
SQLite_Connection.Close

Engine.LogToFile CurrentDb().Name & ".log"

Public Sub Output(text)
  If Me.log.Value <> "" Then Me.log.Value = Me.log.Value & (vbCrLf & text) Else Me.log.Value = Me.log.Value & text
End Sub

Engine.ScriptControl.Run "SetPrintProvider", Me

Dim iVal%, sVal$
    For iVal = Application.Modules.Count - 1 To 0 Step -1
        sVal = Application.Modules(iVal).Name
        'Debug.Print sVal
        If Left(sVal, 5) = "Form_" Then
            If IsFormLoaded(Mid(sVal, 6), True) Then
                Application.DoCmd.Close acForm, Mid(sVal, 6), acSaveYes
            End If
        Else
            Application.DoCmd.Save acModule, sVal
        End If
        
    Next iVal
    Application.RunCommand acCmdCompileAllModules
    ' Application.CloseCurrentDatabase

#If VBA7 Then
 Private Declare PtrSafe Function LockWorkStation Lib "user32.dll" () As Long
#Else
 Declare Function LockWorkStation Lib "user32.dll" () As Long
#End If
 
 
'---------------------------------------------------------------------------------------
' Procedure : LockPC
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Lock the current PC (this does not logoff the user, simply lock the session)
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: None required
' Dependencies: LockWorkStation API Declaration(s)
'
' Usage:
' ~~~~~~
' Call LockPC
'
' ? LockPC
' Returns -> True : when successful
' False : when it fails to lock the PC
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2024-04-11 Initial Public Release
' Added Function header
'---------------------------------------------------------------------------------------
Public Function LockPC() As Boolean
On Error GoTo Error_Handler
 Dim lRet As Long
 
 lRet = LockWorkStation
 If lRet = 0 Then
 Debug.Print "Couldn't lock the PC for an unknown reason."
 Debug.Print Err.LastDllError 'to get more details on the error itself
 Else
 LockPC = True
 Debug.Print "PC Successfully locked!"
 End If
 
Error_Handler_Exit:
 On Error Resume Next
 Exit Function
 
Error_Handler:
 MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
 "Error Source: LockPC" & vbCrLf & _
 "Error Number: " & Err.Number & vbCrLf & _
 "Error Description: " & Err.Description & _
 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
 , vbOKOnly + vbCritical, "An Error has Occurred!"
 Resume Error_Handler_Exit
End Function

If LockPC Then
    'Lock PC Call was successful
Else
    'Lock PC Call was NOT successful
End if

If Not LockPC Then
    Exit Sub
    'Exit Function
End if

'---------------------------------------------------------------------------------------
' Procedure : Crypto_GetStringHash
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Returns the specified Hash for the supplied string.
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding  -> none required
' Dependencies: Requires ReadStringAsBinary()
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInput            : String to get the Hash of
' sHashAlgorithm    : Algorithm to use for the Hashing: MACTripleDES, MD5, RIPEMD160
'                     SHA1, SHA256, SHA384 or SHA512
'
' Usage:
' ~~~~~~
' ? Crypto_GetStringHash("String to get the Hash of", "MD5")
'   Returns -> 69563FFABD2E9D63BF83567F1B664C6
' ? Crypto_GetStringHash("String to get the Hash of", "SHA256")
'   Returns -> 823C17899E52A815FD90EEDDAB5C67B88C1E868E81B88F5ECEFA1D3B17D753
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2023-01-03              Initial Public Release
'---------------------------------------------------------------------------------------
Function Crypto_GetStringHash(sInput As String, sHashAlgorithm As String) As String
    On Error GoTo Error_Handler
    Dim oSSCrypto             As Object
    Dim aFileBytes()          As Byte
    Dim sOutput               As String
    Dim lCounter              As Long
 
    Select Case sHashAlgorithm
        Case "MACTripleDES"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.MACTripleDES")    '
        Case "MD5"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")    '128 bits
        Case "RIPEMD160"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.RIPEMD160Managed")    '160 bits
        Case "SHA1"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.SHA1Managed")    '160 bits
        Case "SHA256"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.SHA256Managed")    '256 bits
        Case "SHA384"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.SHA384Managed")    '384 bits
        Case "SHA512"
            Set oSSCrypto = CreateObject("System.Security.Cryptography.SHA512Managed")    '512 bits
        Case Else
            'MsgBox ""
            GoTo Error_Handler_Exit
    End Select
 
    'aFileBytes() = StrConv(sInput, vbFromUnicode) 'fine for English only.
    aFileBytes() = ReadStringAsBinary(sInput)
    aFileBytes() = oSSCrypto.ComputeHash_2((aFileBytes()))
    For lCounter = 0 To UBound(aFileBytes())
        sOutput = sOutput & UCase(Mid("0" & Hex(aFileBytes(lCounter)), 2))
    Next
    Crypto_GetStringHash = sOutput
 
Error_Handler_Exit:
    On Error Resume Next
    Set oSSCrypto = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Source: Crypto_GetStringHash" & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : ReadStringAsBinary
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Converts the supplied string to a binary array
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding  -> None required
'             Early Binding -> Microsoft ActiveX Data Objects X.X Library
' Based off of ReadFileAsBinary()
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInput     : String to be converted
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2023-01-03              Initial Public Release
'---------------------------------------------------------------------------------------
Public Function ReadStringAsBinary(ByVal sInput As String) As Variant
On Error GoTo Error_Handler
    '#Const EarlyBind = 1    'Use Early Binding
    #Const EarlyBind = 0    'Use Late Binding
    #If EarlyBind Then
        Dim oADOStream As ADODB.Stream
    #Else
        Dim oADOStream As Object
        Const adTypeBinary = 1
    #End If
    Dim aStringBytes() As Byte
 
    #If EarlyBind Then
        Set oADOStream = New ADODB.Stream
    #Else
        Set oADOStream = CreateObject("ADODB.Stream")
    #End If
    With oADOStream
        .Charset = "utf-8"
        .Open
        .WriteText sInput
        .Flush
        .Position = 0
        .Type = adTypeBinary
        .Position = 3    'no bom
        aStringBytes() = .Read
    End With
    ReadStringAsBinary = aStringBytes()
 
Error_Handler_Exit:
    On Error Resume Next
    If Not oADOStream Is Nothing Then
        oADOStream.Close
        Set oADOStream = Nothing
    End If
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Source: ReadStringAsBinary" & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

? Crypto_GetStringHash("Microsoft Access", "SHA512")

C4208CAAFB46AFA43F246676C8331CAD5B955CF7C2CFE4B4D3E404C75F242E16FE59A41C58984587C6FEAA93C9ED0824C4FD4D6FA2B972BB769A27CD094

? Crypto_GetStringHash("Any String You'd Like to Hash", "MD5")

23954A0132E39C143EA654982F3CE0

Public Function IsRunningInDesignatedFolder() As Boolean
 Const sDesignatedFolder = "C:\Databases\CARDA\Demos\Security"
 
 If CurrentProject.Path <> sDesignatedFolder Then
 'MsgBox "This database must be run from the designated folder.", vbCritical Or vbOKOnly
 Application.Quit
 End If
 
 IsRunningInDesignatedFolder = True
End Function

Public Function IsRunningFromDocuments() As Boolean
 Dim sDesignatedFolder As String
 
 sDesignatedFolder = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%UserProfile%\Documents\InventoryDb")
 If CurrentProject.Path <> sDesignatedFolder Then
 'MsgBox "This database must be run from the designated folder.", vbCritical Or vbOKOnly
 Application.Quit
 End If
 
 IsRunningInDesignatedFolder = True
End Function

Public Function IsRunningFromLocalAppData() As Boolean
 Dim sDesignatedFolder As String
 
 sDesignatedFolder = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%LocalAppData%\InventoryDb")
 If CurrentProject.Path <> sDesignatedFolder Then
 'MsgBox "This database must be run from the designated folder.", vbCritical Or vbOKOnly
 Application.Quit
 End If
 
 IsRunningInDesignatedFolder = True
End Function

Public Function StartUp()
 'Check User is allowed
 
 'Check Designated Folder
 Call IsRunningInDesignatedFolder
 
 'Compact Db
 
 'Backup Db
 
 'Relink Tables
 
 'Launch Login or Menu
End Function

Public Function IsRunningInDesignatedFolder() As Boolean
 Const sDesignatedFolder = "\\Server1\Finance"
 
 If CurrentProject.Path = sDesignatedFolder Then
 'MsgBox "This database cannot be run from within the current folder.", vbCritical Or vbOKOnly
 Application.Quit
 End If
 
 IsRunningInDesignatedFolder = True
End Function