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
