Macro to Get Data from Iseries (AS400) using Excel VBA - vba

Question

I am getting data from AS400 via Excel add-in and I'm trying to find an automated to do this because I have to do this many times with various source files and it's annoying to constantly to having to log in whenever I use a new source file.
For instance, for the source file "bond.tto" I would do this to download it:
In Excel,
go to "Add-Ins" --> "Transfer Data from iSeries." A "Transfer Request" window pops up and from there I choose "create a new file"... the path and the file name is c:\bond.tto.
"starting cell position" I chose column A and row 1 and click "include column headings." I press "OK."
then I enter my credentials which let's say my user name is "abc" and pw is "abc." The server...let's call it "BLUE.TOR.MCFLY.COM."
Could somebody suggest code to automate this? Please and thank you.
The macro recorder doesn't give me any lines of code to work with.
No errors as the macro recorder doesn't work.

Answer 1

As a side note, you can also use open JT400 in java to use DB2 SQL to query your tables.
Using VBA you can also use queries as follows:
The code I am using here is primarily from VBA New Database Connection.
However, of importance to you is your database connection string.
This is using the Client Access ODBC driver to connect to an IBM i DB2 database on a server with the name POWER7 and other options. The "translate" option I believe takes it from the 65535 CSSID and converts it to something nice from EBDIC.
Sub DbConnection()
Dim cn As Object ' ADODB.Connection
Set cn = CreateObject("ADODB.Connection") ' New ADODB.Connection
Dim rs As Object ' ADODB.Recordset
Dim strConn As String
strConn = "DRIVER={Client Access ODBC Driver (32-bit)};" & _
"Database=<myDataBase>;" & _
"Hostname=<POWER7>;" & _
"Port=1234;" & _
"Protocol=TCPIP;" & _
"Uid=<USERID>;" & _
"Pwd=<PASSWORD>;" & _
"SYSTEM=<POWER7>;" & _
"DBQ=QGPL <YOUR BASE LIBRARY> <ANOTHER>;" & _
"DFTPKGLIB=QGPL;" & _
"LANGUAGEID=ENU;" & _
"PKG=QGPL/DEFAULT(IBM),2,0,1,0,512;QRYSTGLMT=-1;" & _
"TRANSLATE=1;" & _
"CONNTYPE=2;" & _
"REGIONAL=NO;"
cn.Open strConn
Dim queryArr, i
queryArr = Array("SELECT * FROM <LIBRARY>.<TABLE>")
For i = LBound(queryArr) To UBound(queryArr)
ExecuteQuery queryArr(i), cn, rs
Next i
cn.Close
Set cn = Nothing
End Sub
Private Sub ExecuteQuery(query As Variant, ByRef cn As Object, ByRef rs As Object)
Set rs = CreateObject("ADODB.Recordset") ' New ADODB.Recordset
With rs
.ActiveConnection = cn
.Open CStr(query)
Sheets("Sheet1").Range("A1").CopyFromRecordset rs
.Close
End With
Set rs = Nothing
End Sub

Answer 2

test this:
Option Explicit
Option Base 1
Sub Firmennamen()
On Error GoTo ERRORHANDLER
Dim sSQLFirmen As String
Dim objListObj As ListObject
Dim objListCols As ListColumns
Set WB = ThisWorkbook
Set ws_Einstellungen = WB.Worksheets("Einstellung") ' tab name in excel
Set objListObj = ws_Einstellungen.ListObjects("FirmenNamen") ' table name in excel
Set objListCols = objListObj.ListColumns
ws_Einstellungen.Range("FirmenNamen").ClearContents ' clear table
sconnect = "PROVIDER=IBMDA400;Data Source=server_name;USER ID=username;PASSWORD=Password;"
conn.ConnectionTimeout = 30
conn.Open sconnect
Set mrs.ActiveConnection = conn
sSQLFirmen = " SELECT t.col1 AS Nr, t.col2 AS Firma " & _
" From server_name.schema_name.table_name t " & _
" WHERE t.col2='010' " & _
" ORDER BY t.col1 "
mrs.Open sSQLFirmen, conn
For i = 0 To mrs.fields.count - 1
objListCols(i + 1).Name = mrs.fields(i).Name
Next i
ws_Einstellungen.Range("FirmenNamen").CopyFromRecordset mrs
mrs.Close
conn.Close
Set mrs = Nothing
Set conn = Nothing
Exit Sub
'get out before the Error Handler kicks in
'//////////////////////////////////////////////////////////
ERRORHANDLER:
Call ERROR
End
End Sub
Private Sub Workbook_Open()
Call Firmennamen ' when excel open --> query update
End Sub
Sub ERROR()
Select Case Err.Number
Case -2147217843
msg = "Sie müssen Ihre User ID und Password eintragen: " & Err.Number _
& " oder Ihre user ID und Password sind nicht correct."
MsgBox msg, vbOKOnly
Case 13
msg = "You have text data in a numeric field (" & BadField & "). Fix and re-Upload"
MsgBox msg, vbOKOnly
Case 1004
msg = "Firma fehlt oder ist ungültig !"
MsgBox msg, vbOKOnly
Case Else
msg = "DIe Fehler ist: " & Err.Number & " / " & Err.Description & vbCrLf & vbCrLf & " Bitte sich bei IT melden (mit Screenshot dieser Meldung) !! :( "
MsgBox msg, vbOKOnly
End Select
Err.Clear
'Set GetConnection = Nothing
End Sub