Component Request Pending
I have a program that transfers data from an Excel file to an Access database using DAO.
The problem I am having is when I'm transferring a large amount of data the program locks up. When I click anywhere I get a message box as follows:
Component Request Pending
This action cannot be completed because the other
application is busy. Choose 'Switch To' to activate
the busy application and correct the problem.
When I select the 'Switch To' I get a list of applications currently running. But, everything locks up and I am unable to select any of the applications. I end up having to re-boot the computer.
Following is the code -
'Form wide variables
Option Explicit
Private RecordCount As Long
Private XL As Excel.Application
Private WB As Excel.Workbook
Private WS As Excel.Worksheet
Private Sub cmdTransferData_Click()
Screen.MousePointer = vbHourglass
Set XL = New Excel.Application
Set WB = XL.Workbooks.Open(App.Path & "\Warranty.xls")
Set WS = WB.Worksheets(1)
XL.DisplayAlerts = False
(Other actions)
AddPartNumberInformation
WB.Close
XL.Quit
Set WS = Nothing
Set WB = Nothing
Set XL = Nothing
End Sub
Private Sub AddPartNumberInformation()
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim N As Integer, A As Integer
Dim CurClaimNum As String
On Error GoTo ErrorHandler
'Add Claim Parts Information to Database
Set DB = OpenDatabase(App.Path & "\Warranty.mdb")
Set RS = DB.OpenRecordset("PartsInformation", dbOpenTable)
For N = 1 To RecordCount
If Trim(WS.Cells(N, 4)) <> "" Then
CurClaimNum = Trim(WS.Cells(N, 4))
RS.AddNew
RS!ClaimNumber = CurClaimNum
If Trim(WS.Cells(N, 5)) <> "" Then
If Left(WS.Cells(N, 5), 2) = "TO" Then
RS!PartNumber = Right(WS.Cells(N, 5), Len(WS.Cells(N, 5)) - 2)
Else
RS!PartNumber = WS.Cells(N, 5)
End If
Else
RS!PartNumber = "(no parts)"
End If
RS!PartQty = WS.Cells(N, 6)
RS!PartDescription = WS.Cells(N, 7)
RS.Update
'Find Other parts associated with claim
Do Until Trim(WS.Cells(N + 1, 3)) <> ""
RS.AddNew
RS!ClaimNumber = CurClaimNum
If Trim(WS.Cells(N + 1, 5)) <> "" Then
If Left(WS.Cells(N + 1, 5), 2) = "TO" Then
RS!PartNumber = Right(WS.Cells(N + 1, 5), Len(WS.Cells(N + 1, 5)) - 2)
Else
RS!PartNumber = WS.Cells(N + 1, 5)
End If
Else
RS!PartNumber = "(no parts)"
End If
RS!PartQty = WS.Cells(N + 1, 6)
RS!PartDescription = WS.Cells(N + 1, 7)
RS.Update
If N >= RecordCount Then
Exit Do
Else
N = N + 1
End If
Loop
End If
Me.pgbDataTransfer.Value = Me.pgbDataTransfer.Value + 1
'DoEvents
Next N
Me.pgbDataTransfer.Value = Me.pgbDataTransfer.Max
'DoEvents
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing
Exit Sub
ErrorHandler:
If Err.Number = 3022 Then
Debug.Print "Error on N = " & N & " A = " & A
Resume Next
Else
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing
WB.Close
XL.Quit
Set WS = Nothing
Set WB = Nothing
Set XL = Nothing
MsgBox "Module AddPartNumberInformation" & vbCrLf & vbCrLf & Err.Number & vbCrLf & Err.Description, 16, "Error Message"
End If
End Sub
Any and all help appreciated
Thanks - Ron Gregoire
