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

'Input into a standard text editor, save it with the name RestartDb.vbs 
'and place in the same folder as the front-end
Dim Database
Dim LockFile
Dim i
Dim sAppEXE
Dim sRegKey
 
Database = WScript.Arguments(0)
LockFile = WScript.Arguments(1)
 
Set WshShell = CreateObject("WScript.Shell")
i = 0
'Wait until the lock file is gone
Do While FileExists(LockFile) = True
       PauseScript WshShell, 250
   i = i + 1
   if i >= 40 Then 'Number of loops to test for before exiting without success.  This number can be adjusted
       MsgBox "Unable to restart the Database as the Lock File is not going away.  Please try to relaunch it manually."
       Wscript.Quit
   End If
Loop 
PauseScript WshShell, 750
 
sAppEXE = "MSACCESS.EXE"
sRegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sAppEXE & "\Path"
sAccessPath = WshShell.RegRead(sRegKey)
WshShell.Run _
        chr(34) & sAccessPath & sAppEXE & _
        chr(34) & " " & chr(34) & Database & chr(34)
 
Set WSHShell = Nothing
 
 
 
Function FileExists(FilePath)
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FileExists(FilePath) Then
    FileExists = True
  Else
    FileExists = False
  End If
End Function
 
Function PauseScript(WshShell, Delay)
   'Delay in milliseconds
   If WshShell Is Nothing Then Set WshShell = CreateObject("WScript.Shell")
   WScript.Sleep Delay
End Function

Dim sDatabase             As String
Dim sLockFile             As String
 
' Input argument 1
sDatabase = Application.CurrentDb.Name 
' Input argument 2
sLockFile = Replace(sDatabase, ".accdb", ".laccdb") 
'sLockFile = Replace(sDatabase, ".mdb", ".ldb") 
' Launch the Restart VBScript
Shell "wscript """ & Application.CurrentProject.Path & "\RestartDb.vbs"" """ & _
      sDatabase & """ """ & sLockFile & """"
'Close Access
Application.Quit

'---------------------------------------------------------------------------------------
' Procedure : WMI_IsProcessRunning
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine if a process or Program is running or not
'               Returns: True/False
' 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: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sExeName  : Name of the process to look for
' sHost     : Host computer to query, omit for the local PC
'
' Usage:
' ~~~~~~
' WMI_IsProcessRunning("firefox.exe")
' WMI_IsProcessRunning("outlook.exe")
' WMI_IsProcessRunning("msaccess.exe", "HomePC01")
' WMI_IsProcessRunning("msaccess.exe", "192.168.100.12")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Feb-03             Initial Release
' 2         2020-08-21              Renamed the Function
'                                   Updated Proc Header
'                                   Code updated
'                                   Updated Error Handler
'---------------------------------------------------------------------------------------
Public Function WMI_IsProcessRunning(sProcessName As String, Optional sHost As String = ".") As Boolean
    On Error GoTo Error_Handler
    Dim oWMI                  As Object    'WMI object to query about the PC's OS
    Dim sWMIQuery             As String    'WMI Query
    Dim oCols                 As Object
    Dim oCol                  As Object
 
    Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2")
    sWMIQuery = "SELECT * FROM Win32_Process WHERE Name = '" & sProcessName & "'"
    Set oCols = oWMI.ExecQuery(sWMIQuery)
    If oCols.Count <> 0 Then WMI_IsProcessRunning = True
 
Error_Handler_Exit:
    On Error Resume Next
    Set oCols = Nothing
    Set oWMI = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: WMI_IsProcessRunning" & 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 : WMI_KillProcesse
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Forcibly kill all the instances of a specified process
' 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: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sProcessName  : Name of the process to kill
' sHost         : Host computer to query, omit for the local PC
'
' Usage:
' ~~~~~~
' Call WMI_KillProcesse("explorer.exe")
' Call WMI_KillProcesse("excel.exe")
' Call WMI_KillProcesse("calculator.exe")
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2015-05-28              Initial Release
' 2         2020-08-21              Added Proc Header
'                                   Code updated
'                                   Updated Error Handler
'                                   Made it Option Explicit compliant
'---------------------------------------------------------------------------------------
Public Function WMI_KillProcesse(sProcessName As String, Optional sHost As String = ".") As Boolean
    On Error GoTo Error_Handler
    Dim oWMI                  As Object    'WMI object to query about the PC's OS
    Dim sWMIQuery             As String    'WMI Query
    Dim oCols                 As Object
    Dim oCol                  As Object
 
    Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2")
    sWMIQuery = "SELECT Name FROM Win32_Process"
    Set oCols = oWMI.ExecQuery(sWMIQuery)
    For Each oCol In oCols
        If LCase(sProcessName) = LCase(oCol.Name) Then
            oCol.Terminate    ' Kill this instances of the process
        End If
    Next oCol
    WMI_KillProcesse = True
 
Error_Handler_Exit:
    On Error Resume Next
    Set oCol = Nothing
    Set oCols = Nothing
    Set oWMI = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: WMI_KillProcesse" & 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 : Clipboard_GetText
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Retrieve the clipboard value
' 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
'
' Usage:
' ~~~~~~
' Debug.Print Clipboard_GetText
' sClipboardValue = Clipboard_GetText
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2020-11-25              Initial Public Release
'---------------------------------------------------------------------------------------
Public Function Clipboard_GetText() As String
    On Error GoTo Error_Handler
 
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        Clipboard_GetText = .GetText
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Clipboard_GetText" & 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 : Clipboard_SetText
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Push a string value to the Clipboard
' 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
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInput : The string to push to the clipboard
'
' Usage:
' ~~~~~~
' Call Clipboard_SetText("Hello World")
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2020-11-25              Initial Public Release
'---------------------------------------------------------------------------------------
Public Sub Clipboard_SetText(sInput As String)
    On Error GoTo Error_Handler
 
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText sInput
        .PutInClipboard
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Sub
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Clipboard_SetText" & 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 Sub

Option Compare Database
Option Explicit
 
'am 030305_14:59:26  --begin-- **************
'так как проблема при копировании в буфер тектста
    'в юникода при латинской раскладке
Private Declare Function GetKeyboardLayoutName Lib "user32" _
        Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function LoadKeyboardLayout Lib "user32" _
        Alias "LoadKeyboardLayoutA" (ByVal HKL As String, _
                ByVal flags As Long) As Long
Private Const KL_NAMELENGTH = 9
'am 030305_14:59:26  --end-- **************
 
 
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" _
            (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
            ByVal lpString2 As Any) As Long
Declare Function lstrcpy2 Lib "kernel32" Alias "lstrcpy" _
        (ByVal lpString1 As Any, ByRef lpString2 As Byte) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
            ByVal hMem As Long) As Long
 
Public Const GHND = &H42
Public Const MAXSIZE = 4096
Public Const CF_TEXT = 1
 
 Function ClipBoard_GetData() As String
         Dim hClipMemory As Long
         Dim lpClipMemory As Long
         Dim MyString As String
         Dim RetVal As Long
         Dim lSize As Long
         If OpenClipboard(0&) = 0 Then
            MsgBox "Cannot open Clipboard. Another app. may have it open"
            Exit Function
         End If
 
         ' Obtain the handle to the global memory
         ' block that is referencing the text.
         hClipMemory = GetClipboardData(CF_TEXT)
         If hClipMemory = 0 Then
            MsgBox "Could not allocate memory"
            GoTo OutOfHere
         End If
         'am 040610 - размер нужно узнать
          lSize = GlobalSize(hClipMemory)
 
         ' Lock Clipboard memory so we can reference
         ' the actual data string.
         lpClipMemory = GlobalLock(hClipMemory)
 
         If lpClipMemory <> 0 Then
            MyString = Space$(lSize)
            RetVal = lstrcpy(MyString, lpClipMemory)
            RetVal = GlobalUnlock(hClipMemory)
 
            ' Peel off the null terminating character.
            MyString = mID(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
         Else
            MsgBox "Could not lock memory to copy string from."
         End If
 
OutOfHere:
 
         RetVal = CloseClipboard()
         ClipBoard_GetData = MyString
 
      End Function
 
 
Function ClipBoard_SetData(MyString As String)
         Dim hGlobalMemory As Long, lpGlobalMemory As Long
         Dim hClipMemory As Long, x As Long
 
         ' Allocate movable global memory.
         '-------------------------------------------
         hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
 
         ' Lock the block to get a far pointer
         ' to this memory.
         lpGlobalMemory = GlobalLock(hGlobalMemory)
 
         ' Copy the string to this global memory.
         lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
         'lpGlobalMemory = lstrcpy2(lpGlobalMemory, b(0))
 
         ' Unlock the memory.
         If GlobalUnlock(hGlobalMemory) <> 0 Then
            MsgBox "Could not unlock memory location. Copy aborted."
            GoTo OutOfHere2
         End If
 
         ' Open the Clipboard to copy data to.
         If OpenClipboard(0&) = 0 Then
            MsgBox "Could not open the Clipboard. Copy aborted."
            Exit Function
         End If
 
         ' Clear the Clipboard.
         x = EmptyClipboard()
 
 
        'am 030305_15:16:05  --begin-- **************
        'переключаемся на русскую раскладку чтобы не иметь
        'проблем с русским текстом в буфере
        '(некорректно понимается кодовая страница)
        Dim sOldLang As String
        sOldLang = switchLang("00000419")
        'am 030305_15:16:05  --end-- **************
 
         ' Copy the data to the Clipboard.
         hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
         If CloseClipboard() = 0 Then
            MsgBox "Could not close Clipboard."
         End If
        'am 030305_15:17:26  --begin-- **************
        'возвращаем раскладку на место
        If Len(sOldLang) > 0 Then _
            sOldLang = switchLang(sOldLang)
        'am 030305_15:17:26  --end-- **************
 
End Function
        
Private Function getCurrLang() As String
    Dim layoutname As String * KL_NAMELENGTH
    Dim z As Long
    z = GetKeyboardLayoutName(layoutname)
    If z = 0 Then
        getCurrLang = ""
    Else
        getCurrLang = StrZ(layoutname)
    End If
End Function
'Переключает на указанную sNewLang раскладку - возвращает старую раскладку
'am 030305_15:13:39
Private Function switchLang(sNewLang As String) As String
'"00000419" - русская
'"00000409" - латинская
    switchLang = getCurrLang
    If StrComp(switchLang, sNewLang) <> 0 Then
        LoadKeyboardLayout sNewLang, 1
    End If
End Function
'v_1.0.0 990630
Public Function StrZ(par As String) As String
Dim nSize As Long, i As Long, Rez As String
   nSize = Len(par)
   i = InStr(1, par, Chr(0)) - 1
   If i > nSize Then i = nSize
   If i < 0 Then i = nSize
   StrZ = mID(par, 1, i)
End Function

Sub SetClipboardText(ByVal txt$) ' Запись
   With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText txt$
        .PutInClipboard
    End With
End Sub

Option Compare Database
Option Explicit
 
'К сожалению перечисления только для чисел типа Long
'Для перевода в строку воспользуемся функцией-конвертор ConverterRootKeyName()
'Т.к. начинаем отсчет с 0, то по умолчанию будет первичный раздел HKEY_CURRENT_USER
Public Enum RootKeyName
    rkn_HKEY_CURRENT_USER
    rkn_HKEY_LOCAL_MACHINE
    rkn_HKEY_CLASSES_ROOT
    rkn_HKEY_USERS
    rkn_HKEY_CURRENT_CONFIG
    rkn_HKEY_DYN_DATA
    'rkn_HKEY_PERFORMANCE_DATA
End Enum
 
Private WshShell As Object
Private rknRootKeyName As RootKeyName               'Корневой раздел
 
 
'///////////////   С В О Й С Т В А     ///////////////
 
' Версия
Public Property Get oprVersion() As String
oprVersion = "2.10.030916 L"
End Property
 
'Ключ автозагрузки
Public Property Get oprStartup() As String
oprStartup = "Software\Microsoft\Windows\CurrentVersion\Run\"
End Property
 
Public Property Get oprRootKeyName() As RootKeyName
oprRootKeyName = rknRootKeyName
End Property
 
Public Property Let oprRootKeyName(rknNewValue As RootKeyName)
rknRootKeyName = rknNewValue
End Property
 
 
'///////////////    С О Б Ы Т И Я     ///////////////
Private Sub Class_Initialize()
    Set WshShell = CreateObject("WScript.Shell")
End Sub
 
Private Sub Class_Terminate()
    Set WshShell = Nothing
End Sub
 
 
'///////////////   М Е Т О Д Ы    ///////////////
 
' Функция oprRegGetVal() возврвщает значение ключа реестра
Public Function oprRegGetVal(strSubKey As String) As Variant
On Error GoTo oprRegGetVal_Error
 
    Dim strName As String, varResult As Variant
    
    strName = CompletePath(strSubKey)
    varResult = WshShell.RegRead(strName)
 
oprRegGetVal_Exit:
    oprRegGetVal = varResult
    Exit Function
 
oprRegGetVal_Error:
    If Err.Number = -2147024894 Then varResult = ""
    Resume oprRegGetVal_Exit
End Function
 
' Процедура oprRegWriteVal() создает раздел / параметр.
Public Sub oprRegWriteVal(strSubKey As String, varValue As Variant)
Dim strName As String
    
    strName = CompletePath(strSubKey)
    WshShell.RegWrite strName, varValue
End Sub
 
' Процедура oprRegDelete() Удаляет раздел / параметр.
Public Sub oprRegDelete(strSubKey As String)
On Error GoTo oprRegGetVal_Error
    
    Dim strName As String
    
    strName = CompletePath(strSubKey)
    WshShell.RegDelete (strName)
    
oprRegGetVal_Exit:
    Exit Sub
 
oprRegGetVal_Error:
    If Err.Number = -2147024894 Then
    Else
        MsgBox Err.Description
    End If
    Resume oprRegGetVal_Exit
End Sub
 
' Процедура oprStartupAdd() Создает новый параметр автозагрузки.
Public Sub oprStartupAdd(strProgramName As String, strPathProgram As String)
Dim strSubKey As String, rknRootKeyName As RootKeyName
    
    strSubKey = Me.oprStartup & strProgramName
 
    rknRootKeyName = Me.oprRootKeyName
    
    Me.oprRootKeyName = rkn_HKEY_LOCAL_MACHINE
    Me.oprRegWriteVal strSubKey, strPathProgram
    
    Me.oprRootKeyName = rknRootKeyName
End Sub
 
' Процедура oprStartupDelete() Удаляет параметр автозагрузки.
Public Sub oprStartupDelete(strProgramName As String)
Dim strSubKey As String, rknRootKeyName As RootKeyName
    
    strSubKey = Me.oprStartup & strProgramName
    
    rknRootKeyName = Me.oprRootKeyName
    
    Me.oprRootKeyName = rkn_HKEY_LOCAL_MACHINE
    Me.oprRegDelete strSubKey
    
    Me.oprRootKeyName = rknRootKeyName
End Sub
 
 
'///////////////   Д О П .   Ф У Н К Ц И И    ///////////////
 
' Функция ConverterRootKeyName() возврвщает значение типа строка
Private Function ConverterRootKeyName(lngKey As Long) As String
Dim strKeyName As String
    Select Case lngKey
    Case 0
        strKeyName = "HKCU"
    Case 1
        strKeyName = "HKLM"
    Case 2
        strKeyName = "HKCR"
    Case 3
        strKeyName = "HKEY_USERS"
    Case 4
        strKeyName = "HKEY_CURRENT_CONFIG"
    Case 5
        strKeyName = "HKEY_DYN_DATA"
    Case 6
        strKeyName = "HKEY_PERFORMANCE_DATA"
    Case Else
        strKeyName = ""
    End Select
 
    ConverterRootKeyName = strKeyName
End Function
 
' Функция CompletePath() возврвщает полный путь к параметру
Private Function CompletePath(strPathKey As String) As String
Dim strName As String
 
    strName = Left(strPathKey, 1)
    
    ' Добавим обратный слеж если его нет
    If strName = "\" Then
        strName = ConverterRootKeyName(Me.oprRootKeyName) & strPathKey
    Else
        strName = ConverterRootKeyName(Me.oprRootKeyName) & "\" & strPathKey
    End If
 
    CompletePath = strName
End Function

Public Sub OperationRegistry()
Dim orgOperReg As OperationRegistry
 
Set orgOperReg = New OperationRegistry
 
'Определяем корневай узел HKEY_CURRENT_USER (Но можно не определять,
'по умолчанию HKEY_CURRENT_USER)
orgOperReg.oprRootKeyName = rkn_HKEY_CURRENT_USER
 
' Создаем раздел / параметр
orgOperReg.oprRegWriteVal "Software\MyProgram\Program1\", ""
orgOperReg.oprRegWriteVal "Software\MyProgram\Program2\StringKey", "String Key"
 
' Читаем раздел / параметр
Debug.Print orgOperReg.oprRegGetVal("Software\MyProgram\Program1\")
Debug.Print orgOperReg.oprRegGetVal("Software\MyProgram\Program2\StringKey")
 
' Удаляем раздел / параметр
orgOperReg.oprRegDelete "Software\MyProgram\Program1\"
orgOperReg.oprRegDelete "Software\MyProgram\Program2\StringKey"
orgOperReg.oprRegDelete "Software\MyProgram\"
 
Set orgOperReg = Nothing
End Sub
 
' Добавляем Автозагрузку
Public Sub AddStartup()
Dim orgOperReg As OperationRegistry
Set orgOperReg = New OperationRegistry
 
orgOperReg.oprStartupAdd "База ACCESS", "D:\Мои документы\Access\Refer2002.mde"
 
Set orgOperReg = Nothing
End Sub
 
' Удаляем Автозагрузку
Public Sub DeleteStartup()
Dim orgOperReg As OperationRegistry
Set orgOperReg = New OperationRegistry
 
orgOperReg.oprStartupDelete "База ACCESS"
 
Set orgOperReg = Nothing
End Sub

Private Sub Кнопка6_Click()
ms = "Реально скопировать интерфейс в сетевую папку как новую версию?"
If MsgBox(ms, vbOKCancel, "Copy to base") = 1 Then
ndb = Me.PatchDB.Value & "\" & Me.NameDB
nverdb = Me.PatchDB.Value & "\" & Me.ver & Me.NameDB
Kill ndb
sDatabase = Application.CurrentDb.Name
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile sDatabase, ndb, OverwriteExisting
objFSO.CopyFile sDatabase, nverdb, OverwriteExisting
End If
End Sub