How to multithread a SENDKEYS "{SHIFTDOWN}" call

My Problem. I am working in VB6.

We are seeking to establish a list of Access Databases that make use of data in another key application.
This application will be retired shortly and replaced, hence we need to alter the Access applications to ensure continuity of use.

We can easily find all the linked tables using tableDef from the DAO database properties but need to also find connection strings in the modules that are in use. Therefore to find an Access.Application object we need to use the OpenCurrentDatabase method of the Application object. This works fine.

The problem is, using this method invokes the open event of the database in which some of our application check for the directory they are running from and, if not in the correct location, close down after presenting an message box.  Not a major problem if you can hold the shift key down while the script is running, except it is unrealistic  to stick around for the processing of potentially 3500 Access databases.  

Therefore we would like to open the database holding the shift key down meaning the database will open silently. I have yet to find a successful method of doing this. I have investigated upgrading the application to .NET but this proved to be more work than is realistic.

I found an article about background processes  at http://msdn2.microsoft.com/en-us/library/aa719109.aspx which filled me with hope but cannot seem to adapt it to my situation.

Any help appreciated.
Cheers

Calling Form
=======================================================================
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private WithEvents background As NetFX20Wrapper.BackgroundWorkerWrapper
 
Private Sub background_RunWorkerCompleted(ByVal sender As Variant, ByVal e As NetFX20Wrapper.RunWorkerCompletedEventArgsWrapper)
    If e.Error.Number <> 0 Then
        MsgBox "Error in background process: " & e.Error.Description
    Else
        If e.Cancelled Then
            MsgBox "Background process cancelled."
        Else
            MsgBox "Completed processing of: " & e.GetResult
        End If
    End If
End Sub
 
Private Sub StartBackGroundNow()
    StartBackGround background, "Test Operation"
End Sub
 
Private Sub StopBackGroundNow()
    background.CancelAsync
End Sub
 
Private Sub cmdButton_Click(Index As Integer)
 
    
      StartBackGroundNow
    
      Screen.MousePointer = vbHourglass
      For Each lvLI In lvFoundFiles.ListItems
        If lvLI.Checked = True Then
          If lvLI.ListSubItems(2) = "." Then
            lvLI.ListSubItems(2) = 0
          End If
          If AnalyseTables(lvLI.ListSubItems(1), lvLI.Text, lvLI.ListSubItems(2), sbarStatus) = True Then
            lvLI.Checked = False
            DoEvents
          End If
        End If
      Next
      
      
      Screen.MousePointer = vbDefault
      sbarStatus.Panels(1).Text = "Finished"
      
      Screen.MousePointer = vbHourglass
      StopBackGroundNow
      Sleep 5010
      Screen.MousePointer = vbDefault
          
      unload.me 
  End Select
End Sub
 
==============================================================================================================
 
 
Public Function AnalyseModules(strMDB As String, strMDBPath As String, SearchString As String, ModuleList As String) As Boolean
' --------------------------------------------------------------------------------------------------------------------------------------
' Purpose   :
'
'       This function checks each code module in an access database for the occurance of a particular string.
'       If the string is found the module name is added to as list of modules and returned to the calling function.
'
' Arguments :
'
'    Passed to:
'       strMDB        - the file name of the database being analysed.
'       strMDBPath    - the path to the database being analysed.
'
'    Passed from:
'       ModulesContainingSearchString   - List of modules which contained the search string.
'
' Returns   : Boolean - indicates if database was able to be analysed
' Comments  :
' History   : GP - Created Function 23/1/2008
' --------------------------------------------------------------------------------------------------------------------------------------
 
    On Error GoTo Err_AnalyseModules
    
    Dim background As NetFX20Wrapper.BackgroundWorkerWrapper
 
    AnalyseModules = False
 
    Dim App As Access.Application                                 'Gets an application object so modules may be accessed
    Dim dbModules As Modules
    Dim dbModule As Module
        
    Dim StartLine As Long                                         'Used in Module.Find method - Start line for search
    Dim StartCol As Long                                          'Used in Module.Find method - Start column for search
    Dim EndLine As Long                                           'Used in Module.Find method - End line of search (after match found)
    Dim EndCol As Long                                            'Used in Module.Find method - End column of search (after match found)
    Dim x As Long
    
    Set App = New Access.Application
   
    App.OpenCurrentDatabase strMDBPath & strMDB, False
 
    Set dbModules = App.Modules
    
    For x = 0 To dbModules.Count - 1
        Set dbModule = dbModules(x)
        StartLine = 0
        StartCol = 0
        EndLine = 0
        EndCol = 0
        
        If dbModule.Find(SearchString, StartLine, StartCol, EndLine, EndCol, False, True) Then
            If ModuleList = "" Then
                ModuleList = dbModule.Name
            Else
                ModuleList = ModuleList & ", " & dbModule.Name
            End If
            Debug.Print ModuleList
        End If
    Next
    
    AnalyseModules = True
    App.CloseCurrentDatabase
Exit_Function:
        
    Exit Function
Err_AnalyseModules:
    'Some databases will not be able to be analysed because they need to run in a specific location.
    'When this error occurs we will continue processing and report the database was not checked for connection strings
    
    Resume Exit_Function
End Function
 
==========================================================================================================================
Module1
 
 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Private m_background As NetFX20Wrapper.BackgroundWorkerWrapper
 
Public Sub StartBackGround(background As NetFX20Wrapper.BackgroundWorkerWrapper, argument As Variant)
    Set m_background = background
    m_background.RunWorkerAsync AddressOf BackgroundWork, argument
End Sub
 
Public Sub BackgroundWork(ByRef argument As Variant, ByRef e As NetFX20Wrapper.RunWorkerCompletedEventArgsWrapper)
    On Error GoTo eh
    
    'Err.Raise 1, "", "Something Bad Happened"  ' Force error to test error handling
    
    Dim i As Integer
    For i = 1 To 20
        Sleep 500
        m_background.ReportProgress i * 5
        If m_background.CancellationPending Then
            e.Cancelled = True
            Exit Sub
        End If
    Next
    
    e.SetResult argument
    SendKeys "(SHIFTDOWN}"
    Exit Sub
    
eh:
    e.Error.Number = Err.Number
    e.Error.Description = Err.Description
End Sub

Select allOpen in new window