Form Losing Focus

[robert.thompson.1702]

Hi,

I'm having a problem with Access 2002 which hopefully someone can help
with.

I have a database that is being used for data conversion. I've created
a form which has several command buttons to run the various conversion
processes and a feedback window comprised of 30 text boxes to show the
progress of the processes.

It's all working fine except when I run one of the processes, after
about 30 secs an erroneous Access window appears on the windows taskbar
which takes the focus of the form so the feedback from the running
process is not being shown (I'm assuming it takes the focus but I guess
it could be blocking the code writing to the text boxes?).

I've tried setting the focus back to the form and the repainting it but
this doesn't work. During testing when I was processing a smaller
number of records it worked fine so it seems to be an issue with the
length of time the process takes to execute?

I've posted the code for the process below. Shout if you need any
further info.

All suggestions will be gratefully received.

Cheers
Rob.

Form Command Button

Private Sub cmdRunConversion_Click()

Forms!frmRunConvertProcess!txtProcessStatus15 = ""
Forms!frmRunConvertProcess!txtProcessStatus16 = ""
Forms!frmRunConvertProcess!txtProcessStatus17 = ""
Forms!frmRunConvertProcess!txtProcessStatus18 = ""
Forms!frmRunConvertProcess!txtProcessStatus19 = ""
Forms!frmRunConvertProcess!txtProcessStatus20 = ""
Forms!frmRunConvertProcess!txtProcessStatus21 = ""
Forms!frmRunConvertProcess!txtProcessStatus22 = ""
Forms!frmRunConvertProcess!txtProcessStatus23 = ""
Forms!frmRunConvertProcess!txtProcessStatus24 = ""
Forms!frmRunConvertProcess!txtProcessStatus25 = ""
Forms!frmRunConvertProcess!txtProcessStatus26 = ""
Forms!frmRunConvertProcess!txtProcessStatus27 = ""
Forms!frmRunConvertProcess!txtProcessStatus28 = ""

RunSubscriptionsConversionLoop

Forms!frmRunConvertProcess!.Repaint

RunInfoStringConversionLoop

Forms!frmRunConvertProcess!.Repaint

Forms!frmRunConvertProcess!cmdExportData.Enabled = True
Forms!frmRunConvertProcess!cmdViewConversionResults.Enabled = True

End Sub

Module Code

Sub RunSubscriptionsConversionLoop()

Dim rst As ADODB.Recordset
Dim intCounter As Integer

On Error GoTo errRunSubscriptionsConversionLoop

'Open ImportProcess into a recordset
Set rst = New ADODB.Recordset

rst.Open "ImportProcess", CurrentProject.Connection, adOpenDynamic,
adLockOptimistic

Forms!frmRunConvertProcess!txtProcessStatus17 = Now() & ": " &
"Subscriptions Conversion Started"
Forms!frmRunConvertProcess!txtProcessStatus17.FontBold = False
Forms!frmRunConvertProcess!txtProcessStatus17.ForeColor =
QBColor(0) ' Black

Forms!frmRunConvertProcess.SetFocus
Forms!frmRunConvertProcess.Repaint

'Loop through recordset until EOF
Do While Not rst.EOF

Call ConvertSubscriptions(rst)

intCounter = intCounter + 1

If intCounter Mod 100 = 0 Then
Forms!frmRunConvertProcess!txtProcessStatus18 = Now() & ":
" & intCounter & " rows Converted"
Forms!frmRunConvertProcess!txtProcessStatus18.FontBold =
False
Forms!frmRunConvertProcess!txtProcessStatus18.ForeColor =
QBColor(0) ' Black
End If

Forms!frmRunConvertProcess.SetFocus
Forms!frmRunConvertProcess.Repaint

rst.MoveNext
Loop

Forms!frmRunConvertProcess!txtProcessStatus19 = Now() & ": " &
"Subscriptions Converted Successfully"
Forms!frmRunConvertProcess!txtProcessStatus19.FontBold = False
Forms!frmRunConvertProcess!txtProcessStatus19.ForeColor =
QBColor(2) ' Green

ExitNormal:
Exit Sub

errRunSubscriptionsConversionLoop:
MsgBox "Error with Subscription Conversion Loop:" & Chr(10) &
Chr(10) & Err.Number & " - " & Err.Description & Chr(10), _
vbMsgBoxHelpButton, _
"Subscription Conversion", _
Err.HelpFile, Err.HelpContext

Forms!frmRunConvertProcess!txtProcessStatus19 = Now() & ": " &
"Subscriptions Not Converted"
Forms!frmRunConvertProcess!txtProcessStatus19.FontBold = True
Forms!frmRunConvertProcess!txtProcessStatus19.ForeColor =
QBColor(4) ' Red
Resume ExitNormal

End Sub

Function ConvertSubscriptions(rst As Recordset)

On Error GoTo errConvertSubscriptionString

Dim varFields As Variant
Dim intArrayElements As Integer
Dim intLoopCount As Integer
Dim strSubscriptions As String
Dim dblPunterCode As Double
Dim strSQL As String
Dim intRowCount As Integer

dblPunterCode = rst("PunterCode").Value

If IsNull(rst("Subscriptions").Value) Then
GoTo ExitNormal
Else
strSubscriptions = rst("Subscriptions").Value
End If

' Split the Subscriptions field into it's separate elements
varFields = Split(strSubscriptions, ",")

' count the number of elements
intArrayElements = UBound(varFields) - LBound(varFields) + 1

intLoopCount = 1

Do While intLoopCount <= intArrayElements
strSQL = "SELECT count(*) AS RowCount " & _
"FROM ImportFieldLookup " & _
"WHERE FieldType = 'Subscriptions' " & _
"AND FieldName = '" & Trim(Mid(varFields(intLoopCount
- 1), InStr(varFields(intLoopCount - 1), "'") + 1,
InStrRev(varFields(intLoopCount - 1), "'") -
(InStr(varFields(intLoopCount - 1), "'") + 1))) & "';"
'"AND FieldName LIKE '*" &
Trim(Mid(varFields(intLoopCount - 1), InStr(varFields(intLoopCount -
1), "'") + 1, InStrRev(varFields(intLoopCount - 1), "'") -
(InStr(varFields(intLoopCount - 1), "'") + 1))) & "*';"

intRowCount = CurrentDb.OpenRecordset(strSQL)![RowCount]

If intRowCount = 0 Then
Forms!frmRunConvertProcess!txtProcessStatus20 = Now() & ":
" & "WARNING: New Subscription Fields Detected - Please Check Table
ImportNewFields For Details"
Forms!frmRunConvertProcess!txtProcessStatus20.FontBold =
True
Forms!frmRunConvertProcess!txtProcessStatus20.ForeColor =
QBColor(1) ' Blue

strSQL = "INSERT INTO ImportNewFields(TableToAddTo,
ValuesToAdd) " & _
"SELECT 'Subscriptions', '" &
Replace(varFields(intLoopCount - 1), "'", "", 1, -1, vbTextCompare) &
"';"

DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If

If varFields(intLoopCount - 1) Like "*39*" Then
rst("sub_SunRegistration").Value =
Trim(Mid(varFields(intLoopCount - 1), InStr(varFields(intLoopCount -
1), "'") + 1, InStrRev(varFields(intLoopCount - 1), "'") -
(InStr(varFields(intLoopCount - 1), "'") + 1)))
ElseIf varFields(intLoopCount - 1) Like "*41*" Then
rst("sub_SunCompetitions").Value =
Trim(Mid(varFields(intLoopCount - 1), InStr(varFields(intLoopCount -
1), "'") + 1, InStrRev(varFields(intLoopCount - 1), "'") -
(InStr(varFields(intLoopCount - 1), "'") + 1)))
ElseIf varFields(intLoopCount - 1) Like "*42*" Then
rst("sub_SunEmails").Value =
Trim(Mid(varFields(intLoopCount - 1), InStr(varFields(intLoopCount -
1), "'") + 1, InStrRev(varFields(intLoopCount - 1), "'") -
(InStr(varFields(intLoopCount - 1), "'") + 1)))
ElseIf varFields(intLoopCount - 1) Like "*44*" Then
rst("sub_TheSunOnlineWeeklyEmail").Value =
Trim(Mid(varFields(intLoopCount - 1), InStr(varFields(intLoopCount -
1), "'") + 1, InStrRev(varFields(intLoopCount - 1), "'") -
(InStr(varFields(intLoopCount - 1), "'") + 1)))
End If

intLoopCount = intLoopCount + 1
Loop

ExitNormal:
Exit Function

errConvertSubscriptionString:
MsgBox "Error with Info String Conversion for PunterCode " &
dblPunterCode & Chr(10) & Chr(10) & Err.Number & " - " &
Err.Description & Chr(10), _
vbMsgBoxHelpButton, _
"Info String Conversion", _
Err.HelpFile, Err.HelpContext
Resume ExitNormal

End Function