Update to RFC_READ_TABLE function

Caio Jordão Calisto
[Email redacted]
Hi Jimbo.

First of all, thanks for all your efforts on maintain and share your knowledge regarding the LSWM and SAP Data connections. I'm writing you, and I don't know if it's too late for that, because recently I use your code to integrate ms access and SAP. This code was found in answer to an anonymous question, where you told that you didn't know if the RFC_READ_TABLE accepts more than one Option (Where condition). In fact, it accepts as part of the same string with the END Clause. So, I've updated your code and that's why i'm here, to share with you this update. Feel free to share in your website, if you want to.

I See two ways to improve this code: First, the login box should appear once allowing the programmer to process different tables without having to login again. And the second One, with the update of SAP GUI, the file SAPLogon.INI (Which is the file from where the login window of VBA pulls the information regarding the systems) is no longer used, and it was replaced by an XML file. I'll try to figure out a way to generate a login box with the updated file, and if I achieve it, i'll share with you.

Best Regards:
Caio

Option Compare Database

'Função para ler as tabelas diretamente do SAP
'Adaptada de http://saplsmw.com/Import_tables_directly_into_Access_from_SAP_using_RFCs
'strSAPTable = Tabela SAP a ser lida Ex: "TACTZ"
'strTableName = Tabela Access (Será apagada e reescrita) Ex: "BASE_TACTZ"
'strFields = Nome dos campos que vão ser lidos, separados por virgula Ex: "BROBJ,ACTVT"
'strOption = Funciona como um where para a leitua. As aspas do exemplo são obrigatórias Ex. "ACTVT = '01'"

Function SAP_RFC_READ_TABLE(strSAPTable As String, strTableName As String, strFields As String, Optional strOptions As String = "") As Boolean

    Dim strTemp As String
    
    'Create the database parallel to SAP's . . .
    Dim nCounter As Long, nCurrent As Long
    Dim dbs As dao.Database
    Set dbs = CurrentDb
    Dim tdf As dao.TableDef
    Dim fld1 As dao.Field
    Dim fld2 As dao.Field
    Dim fName As String
    Dim fType As Integer
    Dim fSize As Integer
    Dim nFieldData(999, 2) As Long
    Dim strRow As String
    Dim strFieldnames() As String
    Dim strConvOptions() As String
    Dim FinalRFCQuery As String
    Dim vField As Variant
    Dim j As Integer
    Dim rs As Recordset
    Dim SQL As String
    Dim nCurRec As Long, nCurSec As Long
    Dim isUpdate As Boolean
    Dim strFieldName As String
    Dim nRowCount As Long
    Dim nTotalRecords As Long

    Dim RetVal As Variant, nSecondsLeft As Long, nTotalSeconds As Long
    Dim R3, MyFunc, 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
    
    ' Define the objects to hold the EXPORT parameters
    ' None for RFC_TABLE_READ

    ' Define the objects to hold the TABLES parameters
    ' 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 iRow, iColumn, iStart, iStartRow, iField, iLength As Integer
    
    '**********************************************
    'Create Server object and Setup the connection
    '**********************************************
    
    Dim strSAP_System As String
    Dim strSAP_SystemNumber As String
    Dim strSAP_Client As String
    Dim strSAP_User As String
    Dim strSAP_Password As String
    Dim strSAP_Language As String
    Dim strSAP_ApplicationServer As String

    nTotalSeconds = 0

    Set R3 = CreateObject("SAP.Functions")
    R3.Connection.System = "XXX"
    R3.Connection.SystemNumber = "XX"
    R3.Connection.client = "XXX"
    R3.Connection.User = "XXX"
    R3.Connection.Password = "XXX"
    R3.Connection.Language = "EN"
    R3.Connection.ApplicationServer = "XXX"
       
    RetVal = SysCmd(acSysCmdSetStatus, "Connecting to " & strSAP_System & " . . . ")

    If R3.Connection.logon(0, True) <> True Then
       If R3.Connection.logon(0, False) <> True Then
            Exit Function
       End If
    End If

    '*****************************************************
    'Call RFC function RFC_READ_TABLE
    '*****************************************************
    Set MyFunc = R3.Add("RFC_READ_TABLE")

    ' Set the Objects to the parameter they will return
    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 = strSAPTable
    DELIMITER.Value = vbTab
    NO_DATA = ""
    
    
    'Quebrando o nome dos campos
    j = 0
    strFieldnames = Split(strFields, ",")
    For Each vField In strFieldnames
        j = j + 1
        FIELDS.Rows.Add
        FIELDS.Value(j, "FIELDNAME") = Trim(UCase(vField))
    Next
    
    'Quebrando Lendo condições Where
    j = 0
    If strOptions <> "" Then
    strConvOptions = Split(strOptions, ",")
    FinalRFCQuery = ""
    For Each vField In strConvOptions
    FinalRFCQuery = FinalRFCQuery & Replace(vField, "=", " EQ ", Compare:=vbTextCompare) & " AND "


    Next
    'Terminando a clausula Where
    FinalRFCQuery = Left(FinalRFCQuery, Len(FinalRFCQuery) - 4)
    OPTIONS.Rows.Add
    OPTIONS.Value(1, 1) = Trim(UCase(FinalRFCQuery))
    End If
    
    RetVal = SysCmd(acSysCmdSetStatus, "Extracting " & j & " fields from table " & strSAPTable & " in " & strSAP_System & " . . . ")

    Result = MyFunc.CALL

    If Result = True Then
        Set DATA = MyFunc.Tables("DATA")
        Set FIELDS = MyFunc.Tables("FIELDS")
        Set OPTIONS = MyFunc.Tables("OPTIONS")
    Else
        MsgBox MyFunc.EXCEPTION
        R3.Connection.LOGOFF
        Exit Function
    End If
    
    '*******************************************
    'Quit the SAP Application
    '*******************************************
    R3.Connection.LOGOFF
    
    If Result <> True Then
      MsgBox (MyFunc.EXCEPTION)
      Exit Function
    End If


    nTotalColumns = FIELDS.ROWCOUNT
    'Check for existence of TargetTable
    nCounter = 0
    Do While nCounter < dbs.TableDefs.Count
        If dbs.TableDefs(nCounter).Name = strTableName Then
            'Delete TargetTable--must start from scratch
            dbs.TableDefs.Delete (strTableName)
        End If
        nCounter = nCounter + 1
    Loop
    
    
    Set tdf = dbs.CreateTableDef(strTableName)
    For iField = 1 To FIELDS.ROWCOUNT
        fName = FIELDS(iField, "FIELDNAME")
        fType = dbText
        fSize = FIELDS(iField, "LENGTH")
        Set fld1 = tdf.CreateField(fName, fType, fSize)
        fld1.AllowZeroLength = True
        fld1.Required = False
        tdf.FIELDS.Append fld1
        nFieldData(iField, 1) = FIELDS(iField, "OFFSET")
        nFieldData(iField, 2) = FIELDS(iField, "LENGTH")
    Next
    
    'Create the table in the database
    dbs.TableDefs.Append tdf
    dbs.TableDefs.Refresh

    'Open the table in the Database
    '**************************************
    Set rs = dbs.OpenRecordset(strTableName)
        
    'Display Contents of the table
    '**************************************

    'Class this function up a little...
    RetVal = SysCmd(acSysCmdClearStatus)
    RetVal = SysCmd(acSysCmdInitMeter, "Importing " & strTableName & " from SAP...", DATA.ROWCOUNT)

    iField = 1
    nRowCount = FIELDS.ROWCOUNT
    For iField = 1 To nRowCount
        nFieldData(iField, 1) = FIELDS(iField, "OFFSET")
        nFieldData(iField, 2) = FIELDS(iField, "LENGTH")
    Next
    For iRow = 1 To DATA.ROWCOUNT
        
        nTotalRecords = nTotalRecords + 1
        If Second(Now()) <> nCurSec Then ' And nCurRec <> rs.RecordCount Then
            nCurSec = Second(Now())
            nTotalSeconds = nTotalSeconds + 1
            nSecondsLeft = Int(((nTotalSeconds / iRow) * DATA.ROWCOUNT) * ((DATA.ROWCOUNT - iRow) / DATA.ROWCOUNT))
            RetVal = SysCmd(acSysCmdRemoveMeter)
            RetVal = SysCmd(acSysCmdInitMeter, "Importing " & strTableName & " from SAP, " & nSecondsLeft & " seconds remaining. [" & nTotalRecords & " of " & DATA.ROWCOUNT & "]", DATA.ROWCOUNT)
            RetVal = SysCmd(acSysCmdUpdateMeter, iRow)
            RetVal = DoEvents()
        End If

        
    '   Add a new row to the DB
        strRow = DATA(iRow, 1) 'Pull this into a string rather than pull it from DATA each time...
        
        rs.AddNew
        For iField = 1 To nRowCount
           rs.FIELDS(iField - 1).Value = Trim(Mid(strRow, nFieldData(iField, 1) + 1, nFieldData(iField, 2)))
        Next
        rs.Update
     Next
        
    rs.Close
    Close #2
    Set dbs = Nothing
    Set rs = Nothing
    RetVal = SysCmd(acSysCmdRemoveMeter)
End Function