Since MS changed the way excel 2013 (and beyond) interacts with an AS400 system IBMs traditional Iseries data transfer addin no longer functions as it did. I was provided by the wonderful internet this macro to access the same process into excel but due to auditing requirements I need it to actually prompt for a User name and Password and not use the default hard coded login info in the Macro.
Section to change is the Private Sub InitSQLConnectionDBS
Can anyone out there in the Excel Multiverse help?
Public cnnSQL As New ADODB.Connection
Public iRs1 As Recordset
Public iRs2 As New ADODB.Recordset
Public iRs3 As New ADODB.Recordset
Public iCmd As New ADODB.Command
'AS400 Host Names
Global Const gAS400 = "10.1.7.12"
Global gCommTable(100) As String
_____________________________________________
Private Sub InitSQLConnectionDBS()
Dim strSource As String
On Error GoTo cnnErr
strSource = gAS400
cnnSQL.Provider = "IBMDA400"
' Set USER and PASSWORD next line
cnnSQL.Open "Data Source = " & strSource, "BIZNEZZ", "amgis11"
Exit Sub
cnnErr:
Debug.Print Err.Number & " : " & Err.Description
End Sub
______________________________
Public Function getASWShipment()
'This function retrieves the customers name from ASW and displays it on the worksheet.
'STEP 0. Bypass all errors
On Error Resume Next
'STEP 1. Define Privates
Dim strSQL As String
Dim iCol As Long, iRow As Long, iColOutput As Long
Dim iCus As String, iFrom As String, iTo As String
Dim i As Long, j As Long
Dim inProposal As String
Dim Count As Integer
Worksheets("CreditLimitProposal").Range("A7:Z10000").EntireRow.Delete
inProposal = Worksheets("CreditLimitProposal").Cells(3, 2).Value
'STEP 2. Establish connection to AS400
Set cnnSQL = Nothing
InitSQLConnectionDBS
'STEP 3. Get Data
strSQL = "SELECT CIZ1STAT, CIZ1PPNO,CLZ1TYPE, CIZ1EXRF, CIZ1DENO, NANAME, CIZ1SAAC, CIZ1AVB, CIZ1MULT, CIZ1NPLP, CIZ1CACL, CIZ1CPRO, CIZ1CLMT, CIZ1PPRO, CIZ1PLMT, CIZ1APPR, CIZ1RPRO, CIZ1RLMT, CIZ1RAPR FROM SI2560AFSC.Z1OLP1, SI2560AFSC.Z1OCTLLR, SI2560AFSC.SRONAM WHERE CIZ1PPNO=CLZ1PPNO AND CIZ1DENO = NANUM AND CIZ1PPNO=" & Trim(inProposal)
'MsgBox strSQL
iRs2.Open strSQL, cnnSQL, adOpenStatic, adLockOptimistic, adCmdText
i = 6
' Show column headers
For j = 1 To iRs2.Fields.Count
'Worksheets("CreditLimitProposal").Cells(i, j).Value = iRs2.Fields(j - 1).Name
Next
iRs2.MoveFirst
Do While Not iRs2.EOF
If Err = 0 Then
i = i + 1
' Show data
For j = 1 To iRs2.Fields.Count
Worksheets("CreditLimitProposal").Cells(i, j).Value = iRs2.Fields(j - 1)
Next
End If
iRs2.MoveNext
Loop
iRs2.Close
Set cnnSQL = Nothing
'STEP 99. Housekeeping
exitsub:
iRs2.Close
Set cnnSQL = Nothing
End Function
Attached the Macro in a DOC file