VBScript Send Keys Alternative for Access Table Select All + Copy

[FrEaK_aCcIdEnT]

I have a script that I use to run a macro within and Access DB. Once the new table is populated I perform a send key function to get the data to the clipboard so I can process it through some Excel VBA to get the data formatted and a summary report generated, then exported and emailed.

My problem is that unless I keep my computer unlocked it will not perform the send keys functions below. I am trying to find a way to programatically handle this. I have a workaround, but it is not a secure one... I have a VBScript to keep the computer from locking out... I did this to test the send keys below. I can't leave that running over night while I am not here. Its one of those IT security no no thingies. lol

If I can handle this within Access adding to the macro, I will. I do not have experience with the VBA context in Access. I am more akin to Excel and currently picking up VBScript. Powershell is next on my list...

I appreciate any assistance I can get.

Dim acsApp,xlApp,xlBook

'open MS Access and run macro to pull the data from multiple tables.
Set acsApp = createObject("Access.Application")
Set xlApp = CreateObject("Excel.Application")
Set WshShell = WScript.CreateObject("WScript.Shell")


acsApp.visible = true


acsApp.UserControl = true


acsApp.OpenCurrentDataBase("CHANGE ME"
acsApp.DoCmd.RunMacro "CHANGE ME"


'copy raw data to clipboard
[COLOR=#0000ff][B]WshShell.SendKeys "^a"[/B][/COLOR]
[B][COLOR=#0000ff]WshShell.SendKeys "^c"[/COLOR][/B]


'allow time for everything to copy
WScript.Sleep (15*1000)

 

[Darren Bartrup]

I wouldn't use SendKeys in the first place - too many things to go wrong there. What if another application is opened before ^a is pressed - you'll select the wrong info.

If you want to get the data into Excel I usually do this (from Access):

Main code:

Sub Export_Table()

    Dim oXLApp As Object
    Dim wrkBk As Object
    
    Set oXLApp = CreateXL()
    
    Set wrkBk = oXLApp.workbooks.Add(-4167) 'xlWBATWorksheet - EDIT: Workbook with single worksheet.
    QueryExportToXL wrkBk.worksheets(1), , CurrentDb.OpenRecordset("Table1")
    
End Sub

Code to create or reference an instance of Excel:

Public Function CreateXL(Optional bVisible As Boolean = True) As Object

    Dim oTmpXL As Object


    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Defer error trapping in case Excel is not running. '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Set oTmpXL = GetObject(, "Excel.Application")
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'If an error occurs then create an instance of Excel. '
    'Reinstate error handling.                            '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo ERROR_HANDLER
        Set oTmpXL = CreateObject("Excel.Application")
    End If
    
    oTmpXL.Visible = bVisible
    Set CreateXL = oTmpXL


    On Error GoTo 0
    Exit Function


ERROR_HANDLER:
    Select Case Err.Number
        
        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure CreateXL."
            Err.Clear
    End Select
    
End Function

Code to export a query or recordset to Excel:

'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author    : Darren Bartrup-Cook
' Date      : 26/08/2014
' Purpose   : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
                                                  Optional rst As DAO.Recordset, _
                                                  Optional SheetName As String, _
                                                  Optional rStartCell As Object, _
                                                  Optional AutoFitCols As Boolean = True, _
                                                  Optional colHeadings As Collection) As Boolean


    Dim db As DAO.Database
    Dim prm As DAO.Parameter
    Dim qdf As DAO.QueryDef
    Dim fld As DAO.Field
    Dim oXLCell As Object
    Dim vHeading As Variant
    
    On Error GoTo ERROR_HANDLER
    
    If sQueryName <> "" And rst Is Nothing Then
    
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Open the query recordset.                               '
        'Any parameters in the query need to be evaluated first. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Set db = CurrentDb
        Set qdf = db.QueryDefs(sQueryName)
        For Each prm In qdf.Parameters
            prm.Value = Eval(prm.Name)
        Next prm
        Set rst = qdf.OpenRecordset
    End If
    
    If rStartCell Is Nothing Then
        Set rStartCell = wrkSht.Cells(1, 1)
    Else
        If rStartCell.Parent.Name <> wrkSht.Name Then
            Err.Raise 4000, , "Incorrect Start Cell parent."
        End If
    End If
    
    If Not rst.BOF Or Not rst.EOF Then
        rst.MoveFirst
        With wrkSht
            Set oXLCell = rStartCell
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Paste the field names from the query into row 1 of the sheet. '
            'TO DO: Facility to use an alternative name.                   '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            If colHeadings Is Nothing Then
                For Each fld In rst.Fields
                    oXLCell.Value = fld.Name
                    Set oXLCell = oXLCell.offset(, 1)
                Next fld
            Else
                For Each vHeading In colHeadings
                    oXLCell.Value = vHeading
                    Set oXLCell = oXLCell.offset(, 1)
                Next vHeading
            End If
            
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Work around for CopyFromRecordSet mucking up Excel formatting. '
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Dim oOriginalSheet As Object
            Set oOriginalSheet = wrkSht.Parent.activesheet
            wrkSht.Activate
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Paste the records from the query into row 2 of the sheet. '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Set oXLCell = rStartCell.offset(1, 0)
            oXLCell.copyfromrecordset rst
            
            oOriginalSheet.Activate
            
            If AutoFitCols Then
                .columns.Autofit
            End If
            
            If SheetName <> "" Then
                .Name = SheetName
            End If
            
            '''''''''''''''''''''''''''''''''''''''''''
            'TO DO: Has recordset imported correctly? '
            '''''''''''''''''''''''''''''''''''''''''''
            QueryExportToXL = True
            
        End With
    Else
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'There are no records to export, so the export has failed. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        QueryExportToXL = False
    End If
    
    Set db = Nothing


    On Error GoTo 0
    Exit Function


ERROR_HANDLER:
    Select Case Err.Number
        
        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure QueryExportToXL."
            Err.Clear
    End Select
    
End Function

 

[FrEaK_aCcIdEnT]

I almost have the following working. Im trying to stay away from exporting the data to a new excel file. I would then have to open my excel file and copy the data into it to process using the vba in the background and then delete the original that was exported from access. Just too many extra steps.

I call the function in the macro now. I just dont know the vba syntex to select all the data within a table. Im looking for the same thing that excel uses. (Activesheets.Select)

The asCmdCopy works to copy currently selected content. I just need to select it all....

Sub work()
[B][COLOR=#0000ff]'Me.stores.Address.SetFocus[/COLOR][/B]
DoCmd.RunCommand acCmdCopy
End Sub


Public Function please()
Call work
End Function

 

[mole999]

are you able to record a macro in access to do what you need

 

[FrEaK_aCcIdEnT]

I got it!

I added the following code to the VBScript replacing the sendkeys. I did an initial test which was successful. I will test tonight with the computer locked.


I need to do a google search for "Access RunCommand list" and store it for reference.

acsApp.DoCmd.RunCommand acCmdSelectAll
acsApp.DoCmd.RunCommand acCmdCopy

Thanks for all of the valuable input!

 

[Darren Bartrup]

Glad you got it sorted. As an addendum to my post -

You don't need to create a new workbook, just change the line that adds a new workbook to:

 Set wrkBk = oXLApp.workbooks.Open (Path to your file)