Problem running a batch process 1

[GBall]

Hi,
I've got a form with one button and a label on it.
The click event of the button starts an import process in a module and the label gets updated with the records processed.
Problem is that when I click the button a maximised Access window appears with nothing in it (it's just white), I lose sight of the form and I can't click back into it.
So, I have no idea how well the process is doing.
I'm running Access 2000 sr-1 on XP.
Any ideas,


Regards,
Graham

 

[Remou]

What is the code for the button?

 

[GBall]

Private Sub btnUpdate_Click()
On Error GoTo Err_btnUpdate_Click


Call Update_Schools_Database

Exit_btnUpdate_Click:
Exit Sub

Err_btnUpdate_Click:
MsgBox Err.Description
Resume Exit_btnUpdate_Click

End Sub


Regards,
Graham

 

[Remou]

It seems that there is some code in the Update_Schools_Database module that makes an access application visible, however, without code I can only guess.

 

[GBall]

Ah ! Didn't realise you wanted the lot.
Here it is.

Option Compare Database
Dim strDB As String
Dim strSql As String
Dim strSchema As String
Dim strDB1 As String
Dim strSql1 As String
Dim strSchema1 As String
Dim strProcFunc As String
Dim adoCN1 As New ADODB.Connection
Dim adoCN2 As New ADODB.Connection
Dim intParty_id As Long
Dim intAdviserPartyID As Long
Dim intStructurePointID As Long
Dim intLatestTransactionID As Long
Dim intcurrentrow As Long

Public Sub Update_Schools_Database()
strDB = "exiitest"
strSchema = "exii"
strPassword = "hel1um"
strDB1 = "utiltest"
strSchema1 = "xerix"
strPassword1 = "oracle"
With adoCN1
.ConnectionString = "Provider=MSDAORA.1;User ID=" + strSchema + ";password=" + strPassword + ";Data Source=" + strDB + ";Persist Security Info=True"
.Mode = adModeReadWrite
.Open
End With
With adoCN2
.ConnectionString = "Provider=MSDAORA.1;User ID=" + strSchema1 + ";password=" + strPassword1 + ";Data Source=" + strDB1 + ";Persist Security Info=True"
.Mode = adModeReadWrite
.Open
End With

intcurrentrow = 1
'intLatestTransactionID = GetNext_Transaction()
intLatestTransactionID = 98989999
On Error GoTo error_handler
Set rstcontrol = CurrentDb.OpenRecordset("select_load_data")
With rstcontrol
If Not (.BOF And .EOF) Then
.MoveFirst
While Not (.EOF)
Call Process_School(rstcontrol)
.MoveNext
intcurrentrow = intcurrentrow + 1
[Forms]![frm_update]![Label3].Caption = intcurrentrow
Wend
End If
End With
adoCN1.Close
Set adoCN1 = Nothing
adoCN2.Close
Set adoCN2 = Nothing

MsgBox "Finished at " & Now()
Exit Sub

error_handler:
MsgBox "Error in main module. intcurrentrow = " & intcurrentrow & vbCrLf & Err.Number & " - " & Err.Description
End Sub

Private Sub Process_School(rstcontrol)
strProcFunc = "Process_School"
On Error GoTo error_handler
Dim intAddressID As Long
Dim strPostCode As String
Dim strSchoolname As String
Dim strSchoolnameSrch As String
Dim strEncodedName As String

strSchoolname = Left(Trim(rstcontrol!Name), 80)
strSchoolnameSrch = SF_replaceAllOnce(strSchoolname, "'", "''")

strSql = "select * from t_party@exii where lower(party_name) = '" & LCase(strSchoolnameSrch) & "'"
Dim adoRS1 As New ADODB.Recordset

With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If (.BOF And .EOF) Then
intParty_id = GetNext_T_Party()
.AddNew
!party_id = intParty_id
!PARTY_MERGED_FLAG.Value = "N"
' !INTRODUCING_CAMPAIGN_ID = ""
!party_name.Value = strSchoolname
!SHORT_PARTY_NAME.Value = strSchoolname
' !EMAIL_ADDRESS_TEXT = ""
!PARTY_TYPE_CODE_ID = 15
!ACCESS_SECURITY_CODE_ID = 1
' !MERGE_REASON_CODE_ID = ""
!CREATION_USER_ID = 490007
!CREATION_TIMESTAMP = Now()
!LAST_UPDATE_USER_ID = 490007
!UPDATE_TIMESTAMP = Now()
!LATEST_TRANSACTION_ID = intLatestTransactionID
' !LAST_EXPORT_DATE = ""
.Update
Else
.MoveFirst
intParty_id = !party_id
End If
.Close
End With


strSql = "select * from t_organisation@exii where party_id = " & intParty_id
With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If (.BOF And .EOF) Then
strEncodedName = Encode_name(strSchoolname)
.AddNew
!party_id = intParty_id
' !COMPANY_REGISTRATION_NUMBER = ""
!ORGANISATION_TYPE_CODE_ID = 1007340
!ORGANISATION_NAME.Value = strSchoolname
!ORGANISATION_NAME_ENCODED.Value = strEncodedName
' !ABBREVIATED_ORGANISATION_NAME = ""
' !VAT_REGISTRATION_NUMBER = ""
!CONTACT_NAME.Value = rstcontrol!head_teacher
!PHONE_NUMBER.Value = rstcontrol!phone
' !FAX_NUMBER = ""
' !MOBILE_NUMBER = ""
!CREATION_USER_ID = 490007
!CREATION_TIMESTAMP = Now()
!LAST_UPDATE_USER_ID = 490007
!UPDATE_TIMESTAMP = Now()
!LATEST_TRANSACTION_ID = intLatestTransactionID
.Update
End If
.Close
End With

strSql = "select * from t_party_address@exii where party_id = " & intParty_id
With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If (.BOF And .EOF) Then
intAddressID = GetNext_T_Address()
.AddNew
!PARTY_ADDRESS_ID = GetNext_T_Party_Address()
!ADDRESS_ID = intAddressID
!ADDRESS_TYPE_CODE_ID = 4
!party_id = intParty_id
!ADDRESS_USE_START_DATE = Now()
' !ADDRESS_USE_END_DATE = ""
' !ADDRESS_CARE_OF_NAME = ""
!CREATION_USER_ID = 490007
!CREATION_TIMESTAMP = Now()
!LAST_UPDATE_USER_ID = 490007
!UPDATE_TIMESTAMP = Now()
!LATEST_TRANSACTION_ID = intLatestTransactionID
.Update
Else
intAddressID = !ADDRESS_ID
End If
.Close
End With

strSql = "select * from t_address@exii where address_id = " & intAddressID
With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If (.BOF And .EOF) Then
.AddNew
!ADDRESS_ID = intAddressID
!ADDRESS_LINE1_TEXT.Value = rstcontrol!address1
!ADDRESS_LINE1_ENCODED.Value = Encode_name(rstcontrol!address1)
!ADDRESS_LINE2_TEXT.Value = rstcontrol!address2
!ADDRESS_LINE2_ENCODED.Value = Encode_name(rstcontrol!address2)
!ADDRESS_LINE3_TEXT.Value = rstcontrol!address3
If IsNull(rstcontrol!town) Then
!POST_TOWN_TEXT.Value = "."
Else
!POST_TOWN_TEXT.Value = rstcontrol!town
End If
!COUNTY_NAME_TEXT.Value = rstcontrol!county
If IsNull(rstcontrol!postcode) Then
strPostCode = ""
Else
strPostCode = rstcontrol!postcode
pos = InStr(strPostCode, " ")
If pos > 0 Then
!POST_CODE_OUT_TEXT.Value = Left(strPostCode, pos - 1)
!POST_CODE_IN_TEXT.Value = Mid(strPostCode, pos + 1)
End If
End If
!COUNTRY_CODE_ID = 5
!ADDRESS_VERIFIED_FLAG = "N"
!CREATION_USER_ID = 490007
!CREATION_TIMESTAMP = Now()
!LAST_UPDATE_USER_ID = 490007
!UPDATE_TIMESTAMP = Now()
!LATEST_TRANSACTION_ID = intLatestTransactionID
.Update
End If
.Close
End With


strSql = "select * from sdbt_school_data where school_id = " & intParty_id
With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN2
.Source = strSql
.Open
If (.BOF And .EOF) Then
.AddNew
!SCHOOL_ID = intParty_id
!school_type_code_id = rstcontrol!tps_schooltype
!head_teacher.Value = Left(rstcontrol!head_teacher, 30)
!CREATION_USER_ID = 490007
!CREATION_TIMESTAMP = Now()
!LAST_UPDATE_USER_ID = 490007
!UPDATE_TIMESTAMP = Now()
.Update
End If
.Close
End With


Set adoRS1 = Nothing
Exit Sub

error_handler:
MsgBox "Error in " & strProcFunc & ". intcurrentrow = " & intcurrentrow & vbCrLf & Err.Number & " - " & Err.Description

End Sub
Function Encode_name(text)
src = 1
dest = 1
Dim encodedtext As String

Do While src <= Len(text)
If InStr(1, "',. -", Mid(text, src, 1), vbBinaryCompare) = 0 Then
encodedtext = encodedtext & Mid(text, src, 1)
End If
src = src + 1
Loop
Encode_name = UCase(encodedtext)

End Function

Private Function GetNext_T_Party()

Dim strSql As String
strSql = "select seq_t_party.nextval@exii nextval from dual"
Dim adoRS1 As New ADODB.Recordset

With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If Not (.BOF And .EOF) Then
.MoveFirst
nextval = !nextval
Else
nextval = 0
End If
.Close
End With
Set adoRS1 = Nothing
GetNext_T_Party = nextval

End Function
Private Function GetNext_T_Party_Address()

Dim strSql As String
strSql = "select seq_t_party_address.nextval@exii nextval from dual"
Dim adoRS1 As New ADODB.Recordset

With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If Not (.BOF And .EOF) Then
.MoveFirst
nextval = !nextval
Else
nextval = 0
End If
.Close
End With
Set adoRS1 = Nothing
GetNext_T_Party_Address = nextval

End Function
Private Function GetNext_T_Address()

Dim strSql As String
strSql = "select seq_t_address.nextval@exii nextval from dual"
Dim adoRS1 As New ADODB.Recordset

With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If Not (.BOF And .EOF) Then
.MoveFirst
nextval = !nextval
Else
nextval = 0
End If
.Close
End With
Set adoRS1 = Nothing
GetNext_T_Address = nextval

End Function

Private Function GetNext_Transaction()

Dim strSql As String
strSql = "select Seq_t_business_transaction.nextval@exii nextval from dual"
Dim adoRS1 As New ADODB.Recordset

With adoRS1
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.ActiveConnection = adoCN1
.Source = strSql
.Open
If Not (.BOF And .EOF) Then
.MoveFirst
nextval = !nextval
Else
nextval = 0
End If
.Close
End With
Set adoRS1 = Nothing
GetNext_Transaction = nextval

End Function

Function SF_replace(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String
'replace first occurence of needle in haystack with newneedle
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, newneedle is returned
'if needle is equal to newneedle, haystack is returned
'SF_replace(" This is my string ","my","your") returns " This is your string "
Dim i As Long
If SF_isNothing(Needle) Then
SF_replace = Haystack
Else
If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then
SF_replace = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_replace = Haystack
Else
SF_replace = SF_splitLeft(Haystack, Needle) & NewNeedle & SF_splitRight(Haystack, Needle)
End If
End If
End If
End Function
Function SF_replaceAllOnce(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String
'replace all occurrences of needle in haystack with newneedle exactly once
'if needle is empty or not found, haystack is returned
'if needle is equal to newneedle, haystack is returned
'if needle is equal to haystack, newneedle is returned
'SF_replaceAllOnce(" This is my string ","i","ee") returns " Thees ees my streeng "
Dim i As Long
If SF_isNothing(Needle) Then
SF_replaceAllOnce = Haystack
Else
If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then
SF_replaceAllOnce = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
Do While i > 0
Haystack = Left(Haystack, i - 1) & NewNeedle & Mid(Haystack, i + Len(Needle))
i = i + Len(NewNeedle)
i = InStr(i, Haystack, Needle, vbBinaryCompare)
Loop
SF_replaceAllOnce = Haystack
End If
End If
End Function
Function SF_isNothing(ByVal a As String) As Boolean
'check if there is anything in a string (to avoid testing for
'isnull, isempty, and zero-length strings)
'SF_isNothing(" This is my string ") returns False
If a & "" = "" Then
SF_isNothing = True
Else
SF_isNothing = False
End If
End Function
Function SF_splitLeft(ByVal Haystack As String, ByVal Needle As String) As String
'return left part of haystack delimited by the first occurrence of needle
'if needle is empty or not found, haystack is returned
'if haystack starts with needle (or is equal to needle), a zero-length string is returned
'SF_splitLeft(" This is my string ","s is") returns " Thi"
Dim i As Long
If SF_isNothing(Needle) Then
SF_splitLeft = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_splitLeft = Haystack
Else
SF_splitLeft = Left(Haystack, i - 1)
End If
End If
End Function

Function SF_splitRight(ByVal Haystack As String, ByVal Needle As String) As String
'return right part of haystack delimited by the first occurrence of needle
'if needle is empty or not found, haystack is returned
'if haystack ends with needle (or is equal to needle), a zero-length string is returned
'SF_splitRight(" This is my string "," my s") returns "tring "
Dim i As Long
If SF_isNothing(Needle) Then
SF_splitRight = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_splitRight = Haystack
Else
SF_splitRight = Mid(Haystack, i + Len(Needle))
End If
End If
End Function




Regards,
Graham

 

[TheAceMan1]

how are ya GBall . . .

Try adding [blue]Do Events[/blue] where you see it.

[blue]With rstcontrol
   If Not (.BOF And .EOF) Then
      .MoveFirst
      While Not (.EOF)
         Call Process_School(rstcontrol)
         .MoveNext
         intcurrentrow = intcurrentrow + 1
         [Forms]![frm_update]![Label3].Caption = intcurrentrow
         [purple][b]DoEvents[/b][/purple]
      Wend
   End If
End With[/blue]

See Ya! . . . . . .

 

[GBall]

Spot-on Aceman - thanks.

Regards,
Graham