Public Sub CreateDualTable()
    Dim strSql As String
    strSql = "CREATE TABLE Dual (id COUNTER CONSTRAINT pkey PRIMARY KEY);"
    Debug.Print strSql
    CurrentProject.Connection.Execute strSql
    strSql = "INSERT INTO Dual (id) VALUES (1);"
    Debug.Print strSql
    CurrentProject.Connection.Execute strSql
 
    strSql = "ALTER TABLE Dual" & vbNewLine & _
        vbTab & "ADD CONSTRAINT there_can_be_only_one" & vbNewLine & _
        vbTab & "CHECK (" & vbNewLine & _
        vbTab & vbTab & "(SELECT Count(*) FROM Dual) = 1" & vbNewLine & _
        vbTab & vbTab & ");"
    Debug.Print strSql
    CurrentProject.Connection.Execute strSql
End Sub

powershell -команда

'---------------------------------------------------------------------------------------
' Procedure : PS_Execute
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Run a PowerShell command
' 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:
' ~~~~~~~~~~~~~~~~
' sPSCmd : PowerShell command to run
'
' Usage:
' ~~~~~~
' Copy a File
'   PS_Execute "Copy-Item -Path C:\temp\Book1.xls -Destination C:\temp\charts\Book1.xls -Force"
' Create a Directory or Directories
'   PS_Execute "New-Item -Path 'C:\temp\charts\Test' -ItemType Directory"
'   Can do multiple directories in one call!
'   PS_Execute "New-Item -Path 'C:\temp\charts\Test\1\2\3\4' -ItemType Directory"
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ***********************************************************************************
' 1         2020-04-13              Initial Release
'---------------------------------------------------------------------------------------
Public Sub PS_Execute(ByVal sPSCmd As String)
    'Setup the powershell command properly
    sPSCmd = "powershell -command " & sPSCmd
    'Execute and capture the returned value
    CreateObject("WScript.Shell").Exec (sPSCmd)
End Sub

'---------------------------------------------------------------------------------------
' Procedure : PS_Execute
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Run a PowerShell command
' 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:
' ~~~~~~~~~~~~~~~~
' sPSCmd : PowerShell command to run
'
' Usage:
' ~~~~~~
' Copy a File
'   PS_Execute "Copy-Item -Path C:\temp\Book1.xls -Destination C:\temp\charts\Book1.xls -Force"
' Create a Directory or Directories
'   PS_Execute "New-Item -Path 'C:\temp\charts\Test' -ItemType Directory"
'   Can do multiple directories in one call!
'   PS_Execute "New-Item -Path 'C:\temp\charts\Test\1\2\3\4' -ItemType Directory"
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ************************************************************************************
' 1         2020-04-13              Initial Release
' 2         2024-02-07              Added quotes around command string
'                                   Added ExecutionPolicy, bShowShell, bDebug arguments
'---------------------------------------------------------------------------------------
Public Sub PS_Execute(ByVal sPSCmd As String, _
                      Optional sExecutionPolicy As String, _
                      Optional bShowShell As Boolean = False, _
                      Optional bDebug As Boolean = False)
    'Setup the powershell command properly
    If sExecutionPolicy = "" Then
        sPSCmd = "powershell -command """ & sPSCmd & """"
    Else
        sPSCmd = "powershell -executionpolicy " & sExecutionPolicy & " -command """ & sPSCmd & """"    'Required to make BurntToast work
    End If
    If bDebug Then Debug.Print sPSCmd
    'Execute the command
    If bShowShell Then
        CreateObject("WScript.Shell").Run sPSCmd, 1, True    'Display to user
    Else
        CreateObject("WScript.Shell").Run sPSCmd, 0, True    'Hide from user
    End If
End Sub

'---------------------------------------------------------------------------------------
' Procedure : PS_GetOutput
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : [url]http://www.cardaconsultants.com[/url]
' Purpose   : Run a PowerShell command and return the response
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - [url]https://creativecommons.org/licenses/by-sa/4.0/[/url]
' Req'd Refs: Late Binding  -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPSCmd : PowerShell command to run and return the value/response of
'
' Usage:
' ~~~~~~
' ? PS_GetOutput("Get-ComputerInfo -Property 'OsName'")
'   Returns
'       OsName
'       ------
'       Microsoft Windows 10 Home
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ************************************************************************************
' 1         2020-04-13              Initial Release
'---------------------------------------------------------------------------------------
Public Function PS_GetOutput(ByVal sPSCmd As String) As String
    'Setup the powershell command properly
    sPSCmd = "powershell -command " & sPSCmd
    'Execute and capture the returned value
    PS_GetOutput = CreateObject("WScript.Shell").Exec(sPSCmd).StdOut.ReadAll
End Function

ÿþ
 
 O s N a m e                                       
 
 - - - - - -                                       
 
 M i c r o s o f t   W i n d o w s   1 0   H o m e

'---------------------------------------------------------------------------------------
' Procedure : PS_GetOutput
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : [url]http://www.cardaconsultants.com[/url]
' Purpose   : Run a PowerShell command and return the response
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - [url]https://creativecommons.org/licenses/by-sa/4.0/[/url]
' Req'd Refs: Late Binding  -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPSCmd        : PowerShell command to run and return the value/response of
' sTxtFile      : Text file to output the response to and then read from
' bDelTxtFile   : Whether to delete the generated text file or not
'
' Usage:
' ~~~~~~
'?PS_GetOutput("Get-ComputerInfo -Property 'OsName'", _
'               Environ("userprofile") & "\Desktop\PSTest.txt", False)
'?PS_GetOutput("Get-ComputerInfo -Property 'OsName'")
'   Returns
'       OsName
'       ------
'       Microsoft Windows 10 Home
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ****************************************************************************
' 1         2020-04-13              Initial Release
'---------------------------------------------------------------------------------------
Public Function PS_GetOutput(ByVal sPSCmd As String, _
                              Optional sTxtFile As String = "", _
                              Optional bDelTxtFile As Boolean = True) As String
    'If no Text file was specified create one in the Temp folder
    If sTxtFile = "" Then sTxtFile = Environ("temp") & "\PSTemp.txt"
    'Build the basic PowerShell command
    sPSCmd = "powershell -command " & sPSCmd
    'Add the Out-File so the output generates a text file
    sPSCmd = sPSCmd & " | Out-File '" & sTxtFile & "' -encoding ASCII"
    'Run the PowerShell command
    CreateObject("WScript.Shell").Run sPSCmd, 0, True
    'Retrieve the content of the generated Text file
    With CreateObject("Scripting.FileSystemObject")
        'Read the contents of the text file into memory
        PS_GetOutput = .OpenTextFile(sTxtFile).ReadAll()
        'Delete the text file if so desired
        If bDelTxtFile = True Then .DeleteFile sTxtFile
    End With
End Function

'---------------------------------------------------------------------------------------
' Procedure : PS_GetOutput
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : [url]http://www.cardaconsultants.com[/url]
' Purpose   : Run a PowerShell command and return the response
'               Improved version where the PS prompt is never displayed to the user
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - [url]https://creativecommons.org/licenses/by-sa/4.0/[/url]
' Req'd Refs: Late Binding  -> none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPSCmd : PowerShell command to run and return the value/response of
'
' Usage:
' ~~~~~~
' ? PS_GetOutput("Get-ComputerInfo -Property 'OsName'")
'   Returns
'       OsName
'       ------
'       Microsoft Windows 10 Home
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ****************************************************************************
' 1         2020-11-05              Initial Release
'---------------------------------------------------------------------------------------
Public Function PS_GetOutput(ByVal sPSCmd As String) As String
    'Setup the powershell command properly
    sPSCmd = "powershell -command " & sPSCmd & "|clip"
    'Execute the command which is being pushed to  the clipboard
    CreateObject("WScript.Shell").Run sPSCmd, 0, True
    'Get an instance of the clipboard to capture the save value
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        PS_GetOutput = .GetText(1)
    End With
End Function

Public Sub PS_Admin_Execute(ByVal sPSCmd As String)
'Setup the powershell command properly
    sPSCmd = "powershell -command ""Start-Process powershell -Verb runAs " & _
             "-ArgumentList '-Command " & sPSCmd & "'"""
    'Execute and capture the returned value
    CreateObject("WScript.Shell").Run sPSCmd, 0, True
End Sub

Public Sub PS_Admin_Execute(ByVal sPSCmd As String)
'Setup the powershell command properly
    sPSCmd = "powershell -command ""Start-Process powershell -Verb runAs -WindowStyle Hidden " & _
             "-ArgumentList '-Command " & sPSCmd & "'"""
    'Execute and capture the returned value
    CreateObject("WScript.Shell").Run sPSCmd, 0, True
End Sub

PS_Admin_Execute "Stop-Service -Name spooler"
PS_Admin_Execute "Start-Service -Name spooler"

PS_Admin_Execute "get-netadapter wi-fi |disable-netadapter -confirm:$false"
PS_Admin_Execute "get-netadapter wi-fi |enable-netadapter"

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Function PS_Admin_GetOutput(ByVal sPSCmd As String) As String
Dim i As Long
 
'Setup the powershell command properly
    sPSCmd = "powershell -command ""Start-Process powershell -Verb runAs -WindowStyle Hidden " & _
             "-ArgumentList '-Command " & sPSCmd & "|clip'"""
    'Execute and capture the returned value
    CreateObject("WScript.Shell").Run sPSCmd, 0, True
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        'Wait for a value to appear in the clipboard, remember PowerShell is slow!
        On Error Resume Next
        For i = 0 To 100
            PS_Admin_GetOutput = .GetText(1)
            If Err.Number <> 0 Then
                Err.Clear
            Else
                Exit For
            End If
            Sleep 100 'Don't forget the API declaration!
        Next i
    End With
End Function

? PS_Admin_GetOutput("Get-ComputerInfo -Property ""OsName""")

'---------------------------------------------------------------------------------------
' Procedure : PS_GetStringHash
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Returns the specified Hash for the supplied string.
'             Utilizes PowerShell to perform the Hashing.
' 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 PS_GetOutput()
'
' 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:
' ~~~~~~
' PS_GetStringHash("Testing The Code A Little Bit", "MD5")
'   Returns -> D2A8E6028DEDC41F87E133E036DCCDE2
' PS_GetStringHash("Testing The Code A Little Bit", "RIPEMD160")
'   Returns -> 2037F4F018759E0EC813213CA36ACC20236891D8
' PS_GetStringHash("Testing The Code A Little Bit", "SHA256")
'   Returns -> FB58DAE56E917CD5F5B4A5DEFDEB46B0222E09C660226A69D19381442ABBA51D
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2021-10-06              Initial Public Release
' 2         2022-11-22              Remove trailing vbCrLf per comment by Leslie Desser
'---------------------------------------------------------------------------------------
Function PS_GetStringHash(sInput As String, sHashAlgorithm As String) As String
 
    Dim sPSCmd                As String
 
    On Error GoTo Error_Handler
 
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            GoTo Error_Handler_Exit
    End Select
    sPSCmd = "(Get-FileHash -InputStream ([System.IO.MemoryStream]::" & _
             "New([System.Text.Encoding]::ASCII.GetBytes('" & sInput & "'))) " & _
             "-Algorithm " & sHashAlgorithm & ").Hash"
    PS_GetStringHash = PS_GetOutput(sPSCmd)
    PS_GetStringHash = Replace(PS_GetStringHash, vbCrLf, "")
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_GetStringHash" & 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

'---------------------------------------------------------------------------------------
' Procedure : PS_GetFileHash
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Returns the specified Hash for the supplied file.
'             Utilizes PowerShell to perform the Hashing.
'             Can handle files in excess of 2GB and is faster that standard VBA version.
' 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 PS_GetOutput()
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile             : Fully qualified path and filename to get the Hash of
' sHashAlgorithm    : Algorithm to use for the Hashing: MACTripleDES, MD5, RIPEMD160
'                     SHA1, SHA256, SHA384 or SHA512
'
' Usage:
' ~~~~~~
' PS_GetFileHash("C:\Temp\test.xlsx", "MD5")
'   Returns -> 82BACEED94ACB83CA9B75F69244A2978
' PS_GetFileHash("C:\Temp\Office2013.iso", "SHA1")
'   Returns -> F5D743B0909024F718F65C4C72DE4AA1BE6352C3
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2021-10-06              Initial Public Release
'---------------------------------------------------------------------------------------
Function PS_GetFileHash(sFile As String, sHashAlgorithm As String) As String
    Dim sPSCmd                As String
 
    On Error GoTo Error_Handler
 
    Select Case sHashAlgorithm
        Case "MACTripleDES", "MD5", "RIPEMD160", "SHA1", "SHA256", "SHA384", "SHA512"
        Case Else
            MsgBox "Unknown Algorithm", vbCritical Or vbOKOnly, "Operation Aborted"
            GoTo Error_Handler_Exit
    End Select
    sPSCmd = "(Get-FileHash '" & sFile & "' -Algorithm " & sHashAlgorithm & ").Hash"
    PS_GetFileHash = PS_GetOutput(sPSCmd)
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_GetFileHash" & 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

Function RemoveAttachment(strRemoveFile As String, Optional strFilter As String) As Long
'RemoveAttachment "*.pdf" 'вызов функции - можно указать удаляемые файлы
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Set dbs = CurrentDb
    If Len(strFilter) > 0 Then 'tblAttachments - запрос на выборку записей в которых чистим вложения 
        Set rst = dbs.OpenRecordset("SELECT * FROM tblAttachments WHERE " & strFilter)
    Else
        Set rst = dbs.OpenRecordset("tblAttachments")
    End If
    Set fld = rst("FileV") 'FileV - имя поля с вложениями
    Do While Not rst.EOF
        Set rsA = fld.Value
        Do While Not rsA.EOF
            If rsA("FileName") Like strRemoveFile Then
                rsA.Delete
                RemoveAttachment = RemoveAttachment + 1
            End If
            rsA.MoveNext
        Loop
        rsA.Close
        Set rsA = Nothing
        rst.MoveNext
    Loop
    rst.Close
    dbs.Close
    Set fld = Nothing
    Set rst = Nothing
    Set dbs = Nothing
    MsgBox "Успешно! Удалено вложений - " & RemoveAttachment
End Function

'  Instantiate the parent recordset.  
   Set rsEmployees = db.OpenRecordset("Employees") 
  
   … Code to move to desired employee 
  
   ' Activate edit mode. 
   rsEmployees.Edit 
  
   ' Instantiate the child recordset. 
   Set rsPictures = rsEmployees.Fields("Pictures").Value  
  
   ' Add a new attachment. 
   rsPictures.AddNew 
   rsPictures.Fields("FileData").LoadFromFile "EmpPhoto39392.jpg" 
   rsPictures.Update 
  
   ' Update the parent record 
   rsEmployees.Update

Public Function LoadAttachments(strPath As String, Optional strPattern As String = "*.*") As Long
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFile As String
    
    'Get the database, recordset, and attachment field
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblAttachments")
    Set fld = rst("Attachments")
    
    'Navigate through the table
    Do While Not rst.EOF
    
        'Get the recordset for the Attachments field
        Set rsA = fld.Value
        
        'Load all attachments in the specified directory
        strFile = Dir(strPath & "\*.*")
        
        rst.Edit
        Do While Len(strFile) > 0
            'Add a new attachment that matches the pattern.
            'Pass "" to match all files.
            If strFile Like strPattern Then
                rsA.AddNew
                rsA("FileData").LoadFromFile strPath & "\" & strFile
                rsA.Update
                
                'Increment the number of files added
                LoadAttachments = LoadAttachments + 1
            End If
            strFile = Dir
        Loop
        rsA.Close
        
        rst.Update
        'Next record
        rst.MoveNext
    Loop
    
    rst.Close
    dbs.Close
    
    Set fld = Nothing
    Set rsA = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Function

'  Instantiate the parent recordset.  
   Set rsEmployees = db.OpenRecordset("Employees") 
  
   … Code to move to desired employee 
  
   ' Instantiate the child recordset. 
   Set rsPictures = rsEmployees.Fields("Pictures").Value  
 
   '  Loop through the attachments. 
   While Not rsPictures.EOF 
  
      '  Save current attachment to disk in the "My Documents" folder. 
      rsPictures.Fields("FileData").SaveToFile _ 
                  "C:\Documents and Settings\Username\My Documents" 
      rsPictures.MoveNext 
   Wend

Public Function SaveAttachments(strPath As String, Optional strPattern As String = "*.*") As Long
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFullPath As String
    
    'Get the database, recordset, and attachment field
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblAttachments")
    Set fld = rst("Attachments")
    
    'Navigate through the table
    Do While Not rst.EOF
    
        'Get the recordset for the Attachments field
        Set rsA = fld.Value
        
        'Save all attachments in the field
        Do While Not rsA.EOF
            If rsA("FileName") Like strPattern Then
                strFullPath = strPath & "\" & rsA("FileName")
                
                'Make sure the file does not exist and save
                If Dir(strFullPath) = "" Then
                    rsA("FileData").SaveToFile strFullPath
                End If
                
                'Increment the number of files saved
                SaveAttachments = SaveAttachments + 1
            End If
            
            'Next attachment
            rsA.MoveNext
        Loop
        rsA.Close
        
        'Next record
        rst.MoveNext
    Loop
    
    rst.Close
    dbs.Close
    
    Set fld = Nothing
    Set rsA = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Function

Dim rstFrom As ADODB.Recordset
Dim rstTo As ADODB.Recordset
Dim rstMVF As ADODB.Recordset
Dim rstMVT As ADODB.Recordset
 
Set rstFrom = New ADODB.Recordset
rstFrom.Open "select * from a where Notransaction=1", CurrentProject.Connection, _
              adOpenDynamic, adLockOptimistic
 
Set rstTo = New ADODB.Recordset
rstTo.Open "b", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
 
Do While rstFrom.EOF = False
   rstTo.AddNew
   rstTo!Description = rstFrom![Description]
   Set rstMVF = rstFrom!Photo.Value ' Photo is the attachment data type
   Set rstMVT = rstTo!Photo.Value
' Copy all the attachment in the field Photo (attachment datatype)
   Do While rstMVF.EOF = False
      rstMVT.AddNew
      rstMVT!FileData = rstMVF!FileData
      rstMVT!FileFlags = rstMVF!FileFlags
      rstMVT!FileName = rstMVF!FileName
      rstMVT!FileTimeStamp = rstMVF!FileTimeStamp
      rstMVT!FileType = rstMVF!FileType
      rstMVT!FileURL = rstMVF!FileURL
      rstMVT.Update
      rstMVF.MoveNext
   Loop
   Set rstMVF = Nothing
   Set rstMVT = Nothing
   rstTo.Update
   rstFrom.MoveNext
Loop
rstFrom.Close
rstTo.Close