Code:
- Public Function fcnUploadEmpMst() As Long
-
- 'Note: this VBA code is from Microsoft Access
- ' gthompson@swirecc.com December 2, 2011
- 'Transfer Employee Master to Host server
-
- Dim cmdHost As New ADODB.Command
- Dim cnnHost As New ADODB.Connection
- Dim rstHost As New ADODB.Recordset
- Dim AdoErr As ADODB.Errors
-
- Dim vntHostFields As Variant
- Dim aryHostValues(6) As Variant
- Dim intRowCount As Integer
- Dim db As DAO.Database
- Dim rstUpload As DAO.Recordset
-
- On Error GoTo Error_lbl
-
- Set db = CurrentDb
- Set rstUpload = db.OpenRecordset("qryEmpMstTxt")
-
- 'Set connection for no Journaling/Commitment Control (this is not working !?)
- 'cnnHost.IsolationLevel = adXactChaos
-
- 'Open a connection to Senior
- 'IBMDA400 is the standard OLE DB data access provider
- 'cnnHost.Open "provider=IBMDA400;Data Source=Senior;"
- cnnHost.Open "provider=IBMDA400;Data Source=SENIOR.SWIRECC.COM;"
-
- 'Create and run a command to clear the Host file we are loading
- Set cmdHost.ActiveConnection = cnnHost
- cmdHost.CommandText = "{{CLRPFM BASLOC53/PH10}}"
- cmdHost.CommandType = adCmdText
- cmdHost.Execute
- Set cmdHost = Nothing
-
- 'Open host file to add new records
- Set cmdHost.ActiveConnection = cnnHost
- cmdHost.CommandText = "BASLOC53.PH10()"
- cmdHost.CommandType = adCmdTable
- cmdHost.Properties("Updatability") = 7
- Set rstHost = cmdHost.Execute()
-
- intRowCount = 0
- vntHostFields = Array("EMNBR", "EMNAM", "EMBDGNO", "EMLOC", _
- "EMJOBTL", "EMDEPT", "EMDVSN")
-
- While Not rstUpload.EOF
- With rstUpload
- aryHostValues(0) = !EMPNUM
- aryHostValues(1) = !EMPNAME
- aryHostValues(2) = !BDGNUMTxt
- aryHostValues(3) = !LENT1Txt
- aryHostValues(4) = !JobTitleTxt
- aryHostValues(5) = !DepartmentTxt
- aryHostValues(6) = !DivisionTxt
- End With
- rstHost.AddNew vntHostFields, aryHostValues
- intRowCount = intRowCount + 1
- rstUpload.MoveNext
- If intRowCount Mod 1000 = 0 Then
- Forms!frmUploadToSenior.txtEmpMstRecs.Value = intRowCount
- DoEvents
- End If
- Wend
-
- rstUpload.Close
-
- Exit_lbl:
-
- 'Set rstHost = Nothing
- Set rstUpload = Nothing
- Set cmdHost = Nothing
- Set cnnHost = Nothing
- Set db = Nothing
-
- fcnUploadEmpMst = intRowCount
- Exit Function
-
- Error_lbl:
-
- MsgBox Err.Number & ": " & Err.Description
-
- Resume Exit_lbl
-
- End Function
-
|
|