RFC_READ_TABLE data into MS Access (along with the table structure)

[hynek_petrak]

Consider the below code for educational purposes only. Avoid using RFC_READ_TABLE as it's not released by SAP - see note 382318 - FAQ|Function module RFC_READ_TABLE.

A piece of code, that has been for sure posted many times - how to fetch SAP table data with VBA from within an Excel or MS Access.

However this time the added value is that local MS Access table is created on the fly, based on SAP table structure.

RFC_READ_TABLE(tableName, columnNames, filter, local_table_name)

where tableName - SAP table name to fetch

     columnNames - string, coma separated column names to fetch. If empty string "", then all table fields are retrieved.

     filter - string, WHERE clause in the ABAP SQL syntax

     local_table_name - string, local table name to be created

Example 1:

RFC_READ_TABLE("MAST", "MATNR,WERKS,STLAN,STLNR,STLAL", "WERKS = 'XX10'", "MY_MAST")

... will create local table MY_MAST, with given columns for all MAST records for plant XX10

Example 2:

RFC_READ_TABLE("MARD", "MATNR,LGORT,LGPBE", "LGORT = 'XX60' or LGORT = 'XX61'", "MY_MARD")

... will create local table MY_MARD, with columns MATNR,LGORT,LGPBE, where LGORD is either XX60 or XX61

Example 3:

RFC_READ_TABLE("MARD", "", "LGORT = 'XX60' or LGORT = 'XX61'", "MY_MARD2")

... will create local table MY_MARD2, with all SAP table columns, where LGORD is either XX60 or XX61

Remark: I recommend to use BBP_RFC_READ_TABLE instead of RFC_READ_TABLE, as with the plain RFC_READ_TABLE I had performance problems and crash dumps on large tables.

Public Function RFC_READ_TABLE(tableName, columnNames, filter, table_name)

Dim R3 As Object, MyFunc As Object, App As Object

' Define the objects to hold IMPORT parameters

Dim QUERY_TABLE As Object

Dim DELIMITER   As Object

Dim NO_DATA     As Object

Dim ROWSKIPS    As Object

Dim ROWCOUNT    As Object

' Where clause

Dim OPTIONS As Object

' Fill with fields to return.  After function call will hold

' detailed information about the columns of data (start position

' of each field, length, etc.

Dim FIELDS  As Object

' Holds the data returned by the function

Dim DATA    As Object

' Use to write out results

Dim ROW As Object

Dim Result As Boolean

Dim i As Long, j As Long, iRow As Long

Dim iColumn As Long, iStart As Long, iStartRow As Long, iField As Long, iLength As Long

Dim outArray, vArray, vField

Dim iLine As Long

Dim noOfElements As Long

'**********************************************

'Create Server object and Setup the connection

'use same credentials as SAP GUI DLogin

On Error GoTo abend:

  Set R3 = CreateObject("SAP.Functions")

' Fill below logon details

  R3.Connection.ApplicationServer = "x.x.x.x"

   R3.Connection.SystemNumber = "00"

    R3.Connection.System = "XX1"

    R3.Connection.Client = "120"

    R3.Connection.Password = "password"

  R3.Connection.User = "user"

  R3.Connection.Language = "EN"

  If R3.Connection.Logon(0, True) <> True Then

   RFC_READ_TABLE = "ERROR - Logon to SAP Failed"

   Exit Function

  End If

'**********************************************

'*****************************************************

'Call RFC function RFC_READ_TABLE

'*****************************************************

  Set MyFunc = R3.Add("BBP_RFC_READ_TABLE")

   Set QUERY_TABLE = MyFunc.exports("QUERY_TABLE")

   Set DELIMITER = MyFunc.exports("DELIMITER")

   Set NO_DATA = MyFunc.exports("NO_DATA")

   Set ROWSKIPS = MyFunc.exports("ROWSKIPS")

   Set ROWCOUNT = MyFunc.exports("ROWCOUNT")

   Set OPTIONS = MyFunc.tables("OPTIONS")

   Set FIELDS = MyFunc.tables("FIELDS")

   QUERY_TABLE.Value = tableName

   DELIMITER.Value = ""

   NO_DATA = ""

   ROWSKIPS = "0"

   ROWCOUNT = "0"

   OPTIONS.Rows.Add

   OPTIONS.Value(1, "TEXT") = filter ' where filter

    vArray = Split(columnNames, ",") ' columns

    j = 1

    For Each vField In vArray

        If vField <> "" Then

            FIELDS.Rows.Add

            FIELDS.Value(j, "FIELDNAME") = vField

            j = j + 1

        End If

    Next

   Result = MyFunc.Call

   If Result = True Then

     Set DATA = MyFunc.tables("DATA")

     Set FIELDS = MyFunc.tables("FIELDS")

     Set OPTIONS = MyFunc.tables("OPTIONS")

     R3.Connection.LogOFF

   Else

     R3.Connection.LogOFF

     DLog "SAP RFC Error: " & MyFunc.EXCEPTION

     Exit Function

   End If

  noOfElements = FIELDS.ROWCOUNT

  iRow = 0

  iColumn = 0

  'ReDim outArray(0 To DATA.ROWCOUNT, 0 To noOfElements - 1)

  'For Each ROW In FIELDS.Rows

  '  outArray(iRow, iColumn) = ROW("FIELDNAME")

  '  iColumn = iColumn + 1

  'Next

'Display Contents of the table

'**************************************

iRow = 1

iColumn = 1

Dim l As String

Dim fipos

ReDim fipos(1 To FIELDS.ROWCOUNT, 1 To 3)

Dim db As DAO.Database

Set db = CurrentDb()

Dim sql As String

Dim r As String

On Error Resume Next

db.Execute "DROP TABLE " & table_name & ";"

If Err.Number <> 0 Then

    DLog "DROP TABLE Error: " & Err.Description

End If

On Error GoTo abend:

sql = "CREATE TABLE " & table_name & " ("

Dim sql_ins As String, sql_ins_l As String

'sql_ins = "INSERT INTO " & table_name & " ("

For iColumn = 1 To FIELDS.ROWCOUNT

    fipos(iColumn, 1) = FIELDS(iColumn, "OFFSET") + 1

    fipos(iColumn, 2) = CInt(FIELDS(iColumn, "LENGTH"))

    fipos(iColumn, 3) = FIELDS(iColumn, "FIELDNAME")

    If iColumn = FIELDS.ROWCOUNT Then

        sql = sql & FIELDS(iColumn, "FIELDNAME") & " CHAR(" & fipos(iColumn, 2) & "));"

        'sql_ins = sql_ins & FIELDS(iColumn, "FIELDNAME") & ") VALUES ("

    Else

        sql = sql & FIELDS(iColumn, "FIELDNAME") & " CHAR(" & fipos(iColumn, 2) & "), "

        'sql_ins = sql_ins & FIELDS(iColumn, "FIELDNAME") & ", "

    End If

Next

db.Execute sql

'DLog ("Saving " & DATA.ROWCOUNT & " records in local table " & table_name)

Dim rs As Recordset

Dim le As Long

Set rs = db.OpenRecordset(table_name, dbOpenTable, dbAppendOnly)

BeginTrans

For iLine = 1 To DATA.ROWCOUNT

    l = DATA(iLine, "WA")

    'sql_ins_l = sql_ins

    le = Len(l)

    rs.AddNew

    For iColumn = 1 To FIELDS.ROWCOUNT

         If fipos(iColumn, 1) > le Then

             'outArray(iRow, iColumn - 1) = Null

             'sql_ins_l = sql_ins_l & "NULL"

             GoTo skipme:

         Else

            rs.FIELDS(fipos(iColumn, 3)) = Trim(Mid(l, fipos(iColumn, 1), fipos(iColumn, 2)))

             'outArray(iRow, iColumn - 1) = Mid(l, fipos(iColumn, 1), fipos(iColumn, 2))

             'sql_ins_l = sql_ins_l & "'" & Replace(Mid(l, fipos(iColumn, 1), fipos(iColumn, 2)), "'", "''") & "'"

         End If

         'If iColumn = FIELDS.ROWCOUNT Then

         '   sql_ins_l = sql_ins_l & ") "

         'Else

         '   sql_ins_l = sql_ins_l & ", "

         'End If

         'rs.Update

    Next

skipme:

    rs.Update

    'db.Execute sql_ins_l

Next

CommitTrans

RFC_READ_TABLE = outArray

Exit Function

abend:

RFC_READ_TABLE = Err.Description

End Function