midrange.com code scratchpad
Name:
Gary Thompson
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
12/02/2011 07:10:09 pm
IP:
Logged
Description:
Example of loading data to system i file from Microsoft VBA.
Code:
  1. Public Function fcnUploadEmpMst() As Long
  2.     
  3.     'Note: this VBA code is from Microsoft Access
  4.     '  gthompson@swirecc.com  December 2, 2011
  5.     'Transfer Employee Master to Host server
  6.     
  7.     Dim cmdHost     As New ADODB.Command
  8.     Dim cnnHost     As New ADODB.Connection
  9.     Dim rstHost     As New ADODB.Recordset
  10.     Dim AdoErr      As ADODB.Errors
  11.     
  12.     Dim vntHostFields       As Variant
  13.     Dim aryHostValues(6)    As Variant
  14.     Dim intRowCount         As Integer
  15.     Dim db                  As DAO.Database
  16.     Dim rstUpload           As DAO.Recordset
  17.     
  18. On Error GoTo Error_lbl
  19.  
  20.     Set db = CurrentDb
  21.     Set rstUpload = db.OpenRecordset("qryEmpMstTxt")
  22.     
  23.     'Set connection for no Journaling/Commitment Control (this is not working !?)
  24.     'cnnHost.IsolationLevel = adXactChaos
  25.         
  26.     'Open a connection to Senior
  27.     'IBMDA400 is the standard OLE DB data access provider
  28.     'cnnHost.Open "provider=IBMDA400;Data Source=Senior;"
  29.     cnnHost.Open "provider=IBMDA400;Data Source=SENIOR.SWIRECC.COM;"
  30.     
  31.     'Create and run a command to clear the Host file we are loading
  32.     Set cmdHost.ActiveConnection = cnnHost
  33.     cmdHost.CommandText = "{{CLRPFM  BASLOC53/PH10}}"
  34.     cmdHost.CommandType = adCmdText
  35.     cmdHost.Execute
  36.     Set cmdHost = Nothing
  37.     
  38.     'Open host file to add new records
  39.     Set cmdHost.ActiveConnection = cnnHost
  40.     cmdHost.CommandText = "BASLOC53.PH10()"
  41.     cmdHost.CommandType = adCmdTable
  42.     cmdHost.Properties("Updatability") = 7
  43.     Set rstHost = cmdHost.Execute()
  44.  
  45.     intRowCount = 0
  46.     vntHostFields = Array("EMNBR", "EMNAM", "EMBDGNO", "EMLOC", _
  47.                           "EMJOBTL", "EMDEPT", "EMDVSN")
  48.         
  49.     While Not rstUpload.EOF
  50.         With rstUpload
  51.             aryHostValues(0) = !EMPNUM
  52.             aryHostValues(1) = !EMPNAME
  53.             aryHostValues(2) = !BDGNUMTxt
  54.             aryHostValues(3) = !LENT1Txt
  55.             aryHostValues(4) = !JobTitleTxt
  56.             aryHostValues(5) = !DepartmentTxt
  57.             aryHostValues(6) = !DivisionTxt
  58.         End With
  59.         rstHost.AddNew vntHostFields, aryHostValues
  60.         intRowCount = intRowCount + 1
  61.         rstUpload.MoveNext
  62.         If intRowCount Mod 1000 = 0 Then
  63.             Forms!frmUploadToSenior.txtEmpMstRecs.Value = intRowCount
  64.             DoEvents
  65.         End If
  66.     Wend
  67.     
  68.     rstUpload.Close
  69.     
  70. Exit_lbl:
  71.     
  72.     'Set rstHost = Nothing
  73.     Set rstUpload = Nothing
  74.     Set cmdHost = Nothing
  75.     Set cnnHost = Nothing
  76.     Set db = Nothing
  77.     
  78.     fcnUploadEmpMst = intRowCount
  79.     Exit Function
  80.  
  81. Error_lbl:
  82.     
  83.     MsgBox Err.Number & ": " & Err.Description
  84.     
  85.     Resume Exit_lbl
  86.     
  87. End Function
  88.  
© 2004-2019 by midrange.com generated in 0.006s valid xhtml & css