Mirror an SAP Server Onto a Local Computer Using VBA, RFCs and SQL Server Express
Submitted by Jimbo on Mon, 10/04/2021 - 13:17
Having a mirrored copy of a production SAP server (or a legacy SAP server) can prove immensely useful during an SAP implementation and works wonders for producing extracts with complex joins that can be used to produce load files and to validate loads afterwards. Sadly, not every organization will justify an SLT server or have the willingness to share access to it with key data migration resources.
SAP Replicator is opensource VBA code designed to be run on Microsoft Access to populate a Microsoft SQL Server with the data from an SAP server using RFCs. It initially uses a series of calls to the RFC_READ_TABLE function to take, in small nibbles, a snapshot of SAP tables. The example below was written over a weekend to handle a Material Master data migration project, but code changes can be easily intuited to include other Master Data objects or transactional data where required.
Notes are included in the remarks as to what bits of particularly complex code do. Things like finding a connection string that works and accommodating Master Data numbers that end in letters can be found there.
The SAP_RFC_READ_TABLE VBA function makes another appearance here, but has been heavily modified to reduce traffic on what is likely a production SAP server. Once the initial snapshot is populated with the server data, the deltas can maintain a mirrored copy with fewer than 100 RFC calls per day with processing time on the SAP server taking mere seconds; this can be further reduced by increasing the number of seconds passed to the WaitSeconds() function (see notes in the remarks).
Database Limitations
While SQL Server Express has an absurdly low 10GB size limit for databases, it can still be used for smaller organizations or for larger multinational organizations with some prudent filtering. By extracting only the necessary fields from only the necessary tables, the mirrored data can be maintained without exceeding the threshold. Alternatively, a full Micorosft SQL Server installation can be utilized with SAP Replicator in order to exceed the 10GB database size limitation of SQL Server Express.
The production server for which this code was written has more than eight million Material Masters with some having more than eight hundred pertinent Plant extensions each potentially with dozens of Storage Locations. By filtering out Material Masters and Plant extensions that were unrelated to the project, the mirrored data peaked at just under 10GB and allowed for complex validation and analysis of the data being loaded for the project.
Getting Started
Obtaining a free copy of Microsoft SQL Server Express is accomplished pretty easily with a short Google search; likely, it is the first hit. Getting the software installed on a corporate laptop or virtual desktop is another matter altogether and will not be addressed in this white paper, but the Basic installation is recommended by dint of having been successfully tested with the code below.
Once the SQL Server Express software is installed, be sure to configure it to allow for the software to connect. Start by logging into SQL Server Management Studio (installed separately from SQL Server Express) by connecting to localhost\sqlexpress.
Turn on SQL Server authentication by right-clicking on the server name → Properties → Security and then ticking the SQL Server and Windows Authentication mode under "Server Authentication".
Next, open up port 1433 by launching the SQL Server Configuration Manager and then drilling down to SQL Server Network Configuration → Protocols for SQLEXPRESS → TCP/IP and then setting the TCP Port under "IPALL" (the last entry in the image below) to 1433.
Now the server can be accessed by the software, but a database to hold the contents of the SAP Server needs to be created. In the SSMS tool, right click on Databases → New Database... In the "New Database" window, type the name of the SAP server and click the OK button.
Credentials are required to connect to the SQL Server for this database, so create a new login by clicking on the server name → Security → Logins → New Login. In the "Login - New" window, type in a Login name, add the password and then un-tick the "Enforce password policy" checkbox if the password does not meet the password requirements of the computer.
Next, click on "User Mapping" and then tick the database with the name of the SAP server. Under "Database role membership", be sure to tick db_datareader, db_datawriter and db_owner. The db_owner role allows for the software to create and drop tables in the database.
Click on the OK button and the server is ready to use. The instructions work on regular SQL Server as well as SQL Server Express.
Setting up the software
There is very little left to do at this point. Start by creating a folder on the C: drive of the computer where this software will be running and name that folder "c:\Replicator".
Next, create a new Access database and save it as "c:\Replicator\Replicator.accdb". In the database, create a module by clicking Create → Module.
Change the strConnection value at the top of the code to reflect the settings of the recently created database. Be sure to replace the Database, Uid (user ID) and the Pwd (password) values to match.
While not required, it is strongly recommended to embed the RFC user's credentials in the GetR3() function. Without them, the software stops and waits for the user to manually provide credentials every time the connection is dropped; in an organization with a small SAP server that receives infrequent updates, this may not be much of an inconvenience.
Edit the GetFields() function to include all of the desired fields for each of the tables that will be replicated. Note that when the function returns a zero-length string, the SAP_RFC_READ_TABLE_ToAccess function passes no fields to the BAPI which causes it to return all fields in a table.
Save the module as "Replicator". Finally, run the Replicate() sub.
Things to watch out for
If the combined length of the returned row of data from the RFC_READ_TABLE exceeds 512 characters then the BAPI will return an error explaining that the buffer size has been exceeded. If this happens then reduce the number of fields by listing only those required in the GetFields() function.
Occasionally, a library on which the software relies may cause the program to hang; this might be the library that connects to the SAP server or the library that connects to the SQL server. In this event, just End Task msaccess.exe in the Task Manager and launch the software again; it will pick up where it left off.
If the software is unsuccessful at transferring a block of recently changed data to the server and throws and error starting with "ODBC Insert on a linked table...", it may be that the server is full. Look in SSMS at the database by right-clicking on the database and choosing Properties. The "Space Available" value shown by the server is what is left in the current reservation, but if the "Size" is over 20GB then the database is nearly full.
Access rightfully throws a warning any time Access attemps to open an unrecognized file. This is a natural response designed to protect users from malicious code and viruses.
This creates a problem because the software uses disposable Access databases created on demand to temporarily hold data downloaded from the SAP server. Each time the software attempts to open one of these disposable Access databases, Access throws this warning and waits for a user interaction.
The simplest way to circumvent this warning is to declare that the "c:\Replicator" folder is a Trusted Location. In Access, click on File → Options → Trust Center → Trusted Locations. In the "Trusted Locations" screen, click the Add new location... button and type in c:\Replicator.
So much of this is recycled code from previous projects and the references associated with the VBA code were added over the last 18 years. Ensuring that these libraries are referenced will prevent the code from throwing errors when delcaring objects that rely on these libraries to exist.
The version of each library isn't necessarily important as this code worked 18 years ago with the libraries available at the time. For best results, try to use the most recent version of any library as these tend to be faster, more secure and less prone to cause errors.
The code
This code is provided here as opensource code; use it as much as you like. It is absolutely free and requires no license for either private or commercial usage.
SAP Replicator includes no warranty whatsoever, implied or expressed, so please be prepared to support it yourself. The programmer is spread pretty thin these days, but support may be available at the Contact Us page.
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'* *
'* Replicator 1.2 written by Jim Kauffman October 2021 *
'* *
'* The Replicator tool is designed to mirror an SAP server to *
'* a SQL server and then maintain the mirror by automatically *
'* performing deltas when the data in the SAP server changes. *
'* It is provided without warranty of any kind, expressed or *
'* implied. Support is sparse, but may be obtained at this *
'* address: http://saplsmw.com/contact *
'* *
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Option Compare Database
Dim R3 As Object 'This is the connection that persists as logged in . . .
Const strConnection As String = "Driver={ODBC Driver 13 for SQL Server};Server=sqlserver.domain.int;Database=P01;Uid=replicator;Pwd=Pa$$w0rd;"
'Const strConnection As String = "Driver={SQL Server};Server=localhost;Database=P01;Uid=replicator;Pwd=Pa$$w0rd;"
Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
Sub Replicate()
Dim a As Long, strFields As String, strFileName As String, strTableName As String
Dim nCurrent As Long, nCurrent2 As Long, strCurrent As String
Dim strCheckDate As String, strCheckTime As String, strNextDate As String, strLastCheckTime As String
Dim strCheckDateStop As String, strCheckTimeStop As String, isComplete As Boolean
Dim nWaitSeconds As Long
Dim objDB As adodb.Connection
Dim objRS As adodb.Recordset
Dim db As DAO.database, rs As DAO.Recordset, rs2 As DAO.Recordset
Dim nRecordCount As Long, nRecordCount2 As Long
a = WaitSeconds(5, "Getting started . . .")
If Not GetR3(R3) Then
'Doesn't operate without a connection to SAP...
Exit Sub
End If
strFileName = "c:\replicator\SAP_Date.txt"
strFields = Dir(strFileName)
If strFields = "" Then
'Set today's date as the date from which update searches will start.
strCheckDate = Right("0000" & Year(Now), 4) & Right("00" & Month(Now), 2) & Right("00" & Day(Now), 2)
strCheckTime = "000000"
Open strFileName For Output As #1
Print #1, strCheckDate
Print #1, strCheckDate
Close #1
End If
strFileName = "c:\Replicator\DD03L.accdb"
strFields = Dir(strFileName)
If strFields = "" Then 'This table hasn't been extracted.
'Start by getting the table definitions directly from SAP...
strFields = "TABNAME,FIELDNAME,POSITION,KEYFLAG,ROLLNAME,CHECKTABLE,INTLEN,DATATYPE,LENG"
strFileName = "c:\Replicator\DD03L.accdb"
a = SAP_RFC_READ_TABLE_ToAccess("DD03L", strFileName, strFields, "TABNAME LIKE 'M%' OR TABNAME LIKE 'CA%' OR TABNAME LIKE 'T%' OR TABNAME EQ 'INOB' OR TABNAME EQ 'AUSP' OR TABNAME LIKE 'KS%' OR TABNAME LIKE 'KL%' or TABNAME LIKE 'ST%'")
If DCount("[Name]", "MSysObjects", "[Name] = 'tblDD03L'") = 0 Then
'First time using this file...
DoCmd.TransferDatabase acLink, "Microsoft Access", "c:\replicator\DD03L.accdb", acTable, "DD03L", "tblDD03L"
End If
a = RemoveTableDuplicates("tblDD03L") 'Just in case...
'These don't change every day.
a = SyncronizeData("KSML", "")
a = SyncronizeData("KLAH", "")
a = SyncronizeData("CABN", "")
a = SyncronizeData("CABNT", "SPRAS EQ 'E'")
a = SyncronizeData("CAWN", "")
a = SyncronizeData("CAWNT", "SPRAS EQ 'E'")
a = SyncronizeData("T001L", "")
a = SyncronizeData("T001W", "")
a = SyncronizeData("T024D", "")
a = SyncronizeData("T134M", "")
a = SyncronizeData("T320", "")
a = SyncronizeData("T438M", "")
a = SyncronizeData("T460A", "")
End If
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'* *
'* The following loop pulls an initial snapshot of the Master Data *
'* from the associated tables. Once complete, only incremental *
'* updates as found in the CDHDR table will be added as deltas. *
'* Where the MATNR field exists with letters (instead of only *
'* numbers), the followng line should be "For nCurrent = 1 to 125". *
'* *
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Do While Not isComplete
StartLoop:
On Error GoTo ErrorHandler
Exit Do
For nCurrent = 0 To 1025
If nCurrent < 1000 Then
strCurrent = Right("00" & nCurrent, 3)
Else
'This allows for Master Data that ends with letters. Instead
'of 0 to 999, use 0 to 1025 to get the 26 letters of the alphabet.
strCurrent = Chr(65 + (nCurrent - 1000))
End If
If Not isAlreadyLoaded("MARA", "select top 1 * from MARA where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MARA", "MATNR like '%" & strCurrent & "' AND MTART LIKE 'Y%'")
End If
If Not isAlreadyLoaded("MAKT", "select top 1 * from MAKT where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MAKT", "MATNR like '%" & strCurrent & "' AND SPRAS EQ 'E'")
End If
If Not isAlreadyLoaded("MARC", "select top 1 * from MARC where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MARC", "MATNR like '%" & strCurrent & "' AND ( WERKS LIKE '8%' OR WERKS LIKE 'LZ%' OR WERKS LIKE 'CJ%' )")
End If
If Not isAlreadyLoaded("MARD", "select top 1 * from MARD where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MARD", "MATNR like '%" & strCurrent & "' AND ( WERKS LIKE '8%' OR WERKS LIKE 'LZ%' OR WERKS LIKE 'CJ%' )")
End If
If Not isAlreadyLoaded("MBEW", "select top 1 * from MBEW where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MBEW", "MATNR like '%" & strCurrent & "' AND ( BWKEY LIKE '8%' OR BWKEY LIKE 'LZ%' OR BWKEY LIKE 'CJ%' )")
End If
If Not isAlreadyLoaded("MVKE", "select top 1 * from MVKE where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MVKE", "MATNR like '%" & strCurrent & "' AND ( VKORG LIKE '8H%' OR VKORG LIKE 'LZ%' OR VKORG LIKE 'CJ%' )")
End If
If Not isAlreadyLoaded("MARM", "select top 1 * from MARM where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MARM", "MATNR like '%" & strCurrent & "'")
End If
If Not isAlreadyLoaded("MLAN", "select top 1 * from MLAN where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MLAN", "MATNR like '%" & strCurrent & "'")
End If
If Not isAlreadyLoaded("MLGN", "select top 1 * from MLGN where MATNR like '%" & strCurrent & "'") Then
a = SyncronizeData("MLGN", "MATNR like '%" & strCurrent & "'")
End If
If Not isAlreadyLoaded("KSSK", "select top 1 * from KSSK where OBJEK like '%" & strCurrent & "'") Then
a = SyncronizeData("KSSK", "OBJEK like '%" & strCurrent & "' AND KLART IN ('001','023','ZC1','ZC2','ZCM','ZMM')")
End If
If Not isAlreadyLoaded("INOB", "select top 1 * from INOB where OBJEK like '%" & strCurrent & "'") Then
a = SyncronizeData("INOB", "OBJEK like '%" & strCurrent & "' AND KLART IN ('001','023','ZC1','ZC2','ZCM','ZMM') AND OBTAB EQ 'MARA'")
End If
If Not isAlreadyLoaded("AUSP", "select top 1 * from AUSP where OBJEK like '%" & strCurrent & "'") Then
a = SyncronizeData("AUSP", "OBJEK like '%" & strCurrent & "' AND KLART IN ('001','ZC1','ZC2','ZCM','ZMM')")
End If
RetVal = DoEvents
Next
isComplete = True
Exit Do
ErrorHandler:
'Circle back here any time there is an error in this code or the code below.
isComplete = False
strFileName = "c:\Replicator\Error.log"
Open strFileName For Append As #1
Print #1, Now
Print #1, Err.Number
Print #1, Err.Description
Print #1, Err.Source
Print #1, "-------------------------------------------------"
Close #1
nWaitSeconds = 600
If Err.Source = "wdtfuncs" Then
'See if this resolves the problem "System Resources Exceeded."
'R3.logoff
Set R3 = Nothing
If Not GetR3(R3) Then
'Doesn't operate without a connection to SAP...
a = WaitSeconds(3600)
'Exit Sub
End If
nWaitSeconds = 300
End If
If InStr(Err.Source, "Microsoft") > 0 Then
'SQL connectivity error? VPN down?
nWaitSeconds = 600
End If
nCurrent = WaitSeconds(nWaitSeconds, Err.Description) 'Sleep for an hour
Err.Clear
'Close open tables.
'Set rs = CurrentDb.OpenRecordset("MSysObjects")
'Do While Not rs.EOF
' If Left(rs.FIELDS("Name").Value, 4) <> "MSys" Then 'Skip system tables
' If SysCmd(acSysCmdGetObjectState, rs.FIELDS("Type").Value, rs.FIELDS("Name").Value) <> 0 Then
' RetVal = SysCmd(acSysCmdClearStatus, rs.FIELDS("Type").Value, rs.FIELDS("Name").Value)
' End If
' End If
' rs.MoveNext
'Loop
'rs.Close
If Not rs2 Is Nothing Then
'Erroring out while tblCDPOS is open throws a "Permission denied" error when
'trying to create the new accdb file because the file is still held open.
rs2.Close
Set rs2 = Nothing
End If
Resume StartLoop
Loop
'Exit Sub
Dim strSkipMaterials As String, strOptions As String, nMaterialCount As Long, strMaterials(999999) As String
Dim strTouchedMaterials As String, strTouchedObjects As String, nLoopsWithoutFinds As Long
Dim strCDPOSFilter As String, strMinChangeNumber As String, strMaxChangeNumber As String
Dim strSkipOBJEKs As String, nOBJEKCount As Long, strOBJEKs(999999) As String
nWaitSeconds = 3600 'Check once every so often . . .
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'* *
'* The next lines tease out the deltas from the SAP system. *
'* Chasing down the actual changes in CDHDR and CDPOS are a *
'* bit cumbersome because Classification data is stored in *
'* a particularly cumbersome way therein. *
'* *
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Set db = CurrentDb
Dim strTableList(990, 2) As String, nTableListCount As Long
strTableList(1, 0) = "MATERIAL"
strTableList(1, 1) = "MARA"
strTableList(2, 0) = "MATERIAL"
strTableList(2, 1) = "MARC"
strTableList(3, 0) = "MATERIAL"
strTableList(3, 1) = "MARD"
strTableList(4, 0) = "MATERIAL"
strTableList(4, 1) = "MVKE"
strTableList(5, 0) = "MATERIAL"
strTableList(5, 1) = "MBEW"
strTableList(6, 0) = "MATERIAL"
strTableList(6, 1) = "MAKT"
strTableList(7, 0) = "MATERIAL"
strTableList(7, 1) = "MARM"
strTableList(8, 0) = "MATERIAL"
strTableList(8, 1) = "MLAN"
strTableList(9, 0) = "MATERIAL"
strTableList(9, 1) = "MLGN"
nTableListCount = 9
strFileName = "c:\replicator\SAP_Date.txt"
Open strFileName For Input As #1
Line Input #1, strCheckDate
Line Input #1, strCheckTime
Close #1
Do While True 'Just keep running until told to stop . . .
strSkipMaterials = ""
strSkipOBJEKs = ""
'Break off a window of time in which to determine which Material Masters to update next.
strCheckDateStop = strCheckDate
strCheckTimeStop = Right("000000" & (Val(strCheckTime) + 20000 + (nLoopsWithoutFinds * 10000)), 6)
Do While Val(strCheckTimeStop) > 235959
'Start reading the next day.
strCheckDateStop = AddOneDay(strCheckDateStop)
strCheckTimeStop = Right("000000" & (Val(strCheckTimeStop) - 240000), 6)
Loop
If Val(strCheckTimeStop) > 235900 Then
'Round up to the last second of the day so we can move on to the next day.
strCheckTimeStop = "235959"
End If
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'* *
'* The logic below gets the CDHDR entries between a start date and *
'* start time and a stop date and stop time along with all records *
'* that fall on days between the start date and the stop date. *
'* *
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
If strCheckDate = strCheckDateStop Then
strOptions = "OBJECTCLAS IN ( 'MATERIAL', 'CLASSIFY' ) AND " & _
"( UDATE EQ '" & strCheckDate & "' AND UTIME GE '" & strCheckTime & "' AND UTIME LE '" & strCheckTimeStop & "' )"
Else
strOptions = "OBJECTCLAS IN ( 'MATERIAL', 'CLASSIFY' ) AND " & _
"( " & _
"( UDATE EQ '" & strCheckDate & "' AND UTIME GE '" & strCheckTime & "' ) " & _
"OR ( UDATE GT '" & strCheckDate & "' AND UDATE LT '" & strCheckDateStop & "' ) " & _
"OR ( UDATE EQ '" & strCheckDateStop & "' AND UTIME LE '" & strCheckTimeStop & "' ) " & _
")"
End If
nRecordCount = SAP_RFC_READ_TABLE_ToAccess("CDHDR", "c:\Replicator\CDHDR.accdb", "", strOptions)
If nRecordCount > 0 Then
nLoopsWithoutFinds = 0
nWaitSeconds = 3600 'Assume that this is a slow day.
If DCount("[Name]", "MSysObjects", "[Name] = 'tblCDHDR'") = 0 Then
'First time using this file...
DoCmd.TransferDatabase acLink, "Microsoft Access", "c:\replicator\CDHDR.accdb", acTable, "CDHDR", "tblCDHDR"
End If
strOptions = ""
'strNextDate = ""
Set rs = db.OpenRecordset("select * from tblCDHDR where OBJECTCLAS = 'MATERIAL' and UDATE = '" & strCheckDate & "'")
strTouchedMaterials = ""
strCDPOSFilter = ""
strMinChangeNumber = ""
strMaxChangeNumber = ""
Do While Not rs.EOF
If strMinChangeNumber = "" Or strMinChangeNumber > rs.FIELDS("CHANGENR").Value Then
strMinChangeNumber = rs.FIELDS("CHANGENR").Value
End If
If strMaxChangeNumber = "" Or strMaxChangeNumber < rs.FIELDS("CHANGENR").Value Then
strMaxChangeNumber = rs.FIELDS("CHANGENR").Value
End If
rs.MoveNext
Loop
rs.Close
If strMinChangeNumber <> "" Then 'Found some records . . .
For nCurrent = 1 To nTableListCount
strTableList(nCurrent, 2) = ""
Next
strCDPOSFilter = "OBJECTCLAS = 'MATERIAL' AND ( CHANGENR GE '" & strMinChangeNumber & "' AND CHANGENR LE '" & strMaxChangeNumber & "' )"
nRecordCount2 = SAP_RFC_READ_TABLE_ToAccess("CDPOS", "c:\Replicator\CDPOS.accdb", "OBJECTCLAS,OBJECTID,CHANGENR,TABNAME,TABKEY", strCDPOSFilter)
If DCount("[Name]", "MSysObjects", "[Name] = 'tblCDPOS'") = 0 Then
'First time using this file...
DoCmd.TransferDatabase acLink, "Microsoft Access", "c:\replicator\CDPOS.accdb", acTable, "CDPOS", "tblCDPOS"
End If
Set rs2 = db.OpenRecordset("select * from tblCDPOS order by OBJECTID, TABNAME")
Do While Not rs2.EOF
'Reduce the length of strOptions for organizations with many Plants and Storage Locations.
For nCurrent = 1 To nTableListCount
If InStr(rs2.FIELDS("TABNAME").Value, strTableList(nCurrent, 1)) > 0 Then 'Only pull from applicable tables.
'Since we're pulling all the records for this table, only include the Material Master number once.
strOptions = "MATNR EQ '" & rs2.FIELDS("OBJECTID").Value & "'"
If strTableList(nCurrent, 1) = "MARA" Then
strOptions = "( " & strOptions & " AND MTART LIKE 'Y%' )"
ElseIf strTableList(nCurrent, 1) = "MARC" Then
strOptions = "( " & strOptions & " AND WERKS EQ '" & Mid(rs2.FIELDS("TABKEY").Value, 22, 4) & "' )"
ElseIf strTableList(nCurrent, 1) = "MARD" Then
'strOptions = "( " & strOptions & " AND WERKS EQ '" & Mid(rs2.FIELDS("TABKEY").Value, 22, 4) & "' AND LGORT EQ '" & Mid(rs2.FIELDS("TABKEY").Value, 26, 4) & "' )"
strOptions = "( " & strOptions & " AND WERKS EQ '" & Mid(rs2.FIELDS("TABKEY").Value, 22, 4) & "' )"
ElseIf strTableList(nCurrent, 1) = "MBEW" Then
strOptions = "( " & strOptions & " AND BWKEY EQ '" & Mid(rs2.FIELDS("TABKEY").Value, 22, 4) & "' )"
ElseIf strTableList(nCurrent, 1) = "MAKT" Then
strOptions = "( " & strOptions & " AND SPRAS EQ 'E' )"
End If
If InStr(strTableList(nCurrent, 2), strOptions) < 1 Then
If strTableList(nCurrent, 2) <> "" Then
strTableList(nCurrent, 2) = strTableList(nCurrent, 2) & " OR "
End If
strTableList(nCurrent, 2) = strTableList(nCurrent, 2) & strOptions
End If
End If
Next
rs2.MoveNext
For nCurrent = 1 To nTableListCount
'This value can max out at 19000. Watch out for "System Resources Exceeded" error.
If Len(strTableList(nCurrent, 2)) > 18000 Or (Len(strTableList(nCurrent, 2)) > 0 And rs2.EOF) Then
a = SyncronizeData(strTableList(nCurrent, 1), strTableList(nCurrent, 2))
a = WaitSeconds(5, strCheckDate & " " & strCheckTime & ", Updated " & strTableList(nCurrent, 1) & " " & a & " records.")
strTableList(nCurrent, 2) = "" 'Start over. Phew!
End If
Next
Loop
RetVal = DoEvents
rs2.Close
Set rs2 = Nothing
Else
nLoopsWithoutFinds = nLoopsWithoutFinds + 1
End If
Set rs = Nothing
' Now do the Classification check...
strOptions = "select * from tblCDHDR where OBJECTCLAS = 'CLASSIFY' and UDATE = '" & strCheckDate & "'"
Set rs = db.OpenRecordset(strOptions)
strTouchedObjects = ""
strOptions = ""
Do While Not rs.EOF
If rs.FIELDS("UDATE").Value = strCheckDate Then 'Only one day at a time . . .
If InStr(strTouchedObjects, Left(rs.FIELDS("OBJECTID").Value, 18)) < 1 Then
'Ensure that we do not update the Material more than once during a loop.
strTouchedObjects = strTouchedObjects & Left(rs.FIELDS("OBJECTID").Value, 18)
If strOptions <> "" Then
strOptions = strOptions & " OR "
End If
strOptions = strOptions & "CUOBJ EQ '" & Left(rs.FIELDS("OBJECTID").Value, 18) & "'"
End If
End If
rs.MoveNext
If Len(strOptions) > 19000 Or (Len(strOptions) > 0 And rs.EOF) Then
a = SyncronizeData("INOB", "( " & strOptions & " ) AND OBTAB EQ 'MARA'") 'Classifications
strOptions = ""
If a > 0 Then
Set rs2 = db.OpenRecordset("INOB")
Do While Not rs2.EOF
If strOptions <> "" Then
strOptions = strOptions & " OR "
End If
strOptions = strOptions & "OBJEK EQ '" & Left(rs2.FIELDS("CUOBJ").Value, 18) & "'"
rs2.MoveNext
Loop
rs2.Close
Set rs2 = Nothing
a = SyncronizeData("KSSK", "( " & strOptions & " ) AND KLART IN ('001','023','ZC1','ZC2','ZCM','ZMM')") '001 Classifications
a = SyncronizeData("AUSP", "( " & strOptions & " ) AND KLART IN ('023','ZC1','ZC2','ZCM','ZMM')") '001 Classifications
a = WaitSeconds(10, strCheckDate & " " & strCheckTime)
End If
strOptions = ""
End If
Loop
rs.Close
Set rs = Nothing
' Now determine the date and time to start the next run . . .
strOptions = "select * from tblCDHDR"
Set rs = db.OpenRecordset(strOptions)
Do While Not rs.EOF
If rs.FIELDS("UDATE").Value > strCheckDate Then
'Use some logic to get the next day with activity . . .
If rs.FIELDS("UDATE").Value < strNextDate Or strNextDate = "" Then
strNextDate = rs.FIELDS("UDATE").Value
End If
Else
If rs.FIELDS("UTIME").Value > strCheckTime Then
'Start the next check here...
strCheckTime = AddOneSecond(rs.FIELDS("UTIME").Value)
If ToSAPDate(Now()) < strCheckDate Then
nWaitSeconds = 90 ' We can start the next loop more quickly...
Else
If Val(strCheckTime) - Val(strLastCheckTime) > 4000 Then
'We haven't caught up to the server's time yet.
nWaitSeconds = 90
Else
nWaitSeconds = 3600 ' Can relax for 60 minutes.
End If
End If
End If
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Else
nLoopsWithoutFinds = nLoopsWithoutFinds + 1
nWaitSeconds = 3600 ' It's a slow day...
End If
'Pick up on the next day if this one is finished...
If strNextDate > strCheckDate Then
'The CDHDR has been read to the end of the day; we start the clock
'at 000000 to ensure no data is lost.
strCheckDate = strNextDate
strCheckTime = "000000"
strNextDate = ""
Else
If strLastCheckTime = strCheckTime Then
'Ensure that the system isn't stuck on one record with
'a long gap after it...
strCheckTime = AddOneSecond(strCheckTime)
nLoopsWithoutFinds = nLoopsWithoutFinds + 1
Else
strLastCheckTime = strCheckTime
End If
End If
strFileName = "c:\replicator\SAP_Date.txt"
Open strFileName For Output As #1
Print #1, strCheckDate
Print #1, strCheckTime
Close #1
RetVal = DoEvents
a = WaitSeconds(nWaitSeconds, strCheckDate & " " & strCheckTime)
Loop
Set db = Nothing
End Sub
Function AddOneDay(strDate As String) As String
Dim dDate As Date
dDate = DateSerial(Left(strDate, 4), Mid(strDate, 5, 2), Right(strDate, 2))
dDate = DateAdd("d", 1, dDate)
AddOneDay = Year(dDate) & Right("00" & Month(dDate), 2) & Right("00" & Day(dDate), 2)
End Function
Function AddOneSecond(strTime) As String
Dim nHours As Integer, nMinutes As Integer, nSeconds As Integer
If Val(strTime) < 235959 Then
nHours = Left(strTime, 2)
nMinutes = Mid(strTime, 3, 2)
nSeconds = Right(strTime, 2)
nSeconds = nSeconds + 1
If nSeconds > 59 Then
nSeconds = 0
nMinutes = nMinutes + 1
If nMinutes > 59 Then
nMinutes = 0
nHours = nHours + 1
End If
End If
AddOneSecond = Right("00" & nHours, 2) & Right("00" & nMinutes, 2) & Right("00" & nSeconds, 2)
Else
'Cannot add one second . . .
AddOneSecond = strTime
End If
End Function
Function GetR3(ByRef R3 As Object) As Boolean
Set R3 = CreateObject("SAP.Functions")
'*************************************
' Put in your own credentials here.
'*************************************
R3.Connection.System = "P01"
R3.Connection.SystemNumber = "00"
R3.Connection.client = "100"
R3.Connection.User = "username"
R3.Connection.Password = "password"
R3.Connection.LANGUAGE = "EN"
R3.Connection.ApplicationServer = "sapserver.domain.int"
If R3.Connection.logon(0, True) <> True Then
If R3.Connection.logon(0, False) <> True Then
GetR3 = False
Exit Function
End If
End If
GetR3 = True
End Function
Function SyncronizeData(strTableName As String, strOptions As String) As Long
Dim objDB As adodb.Connection
Dim objRS As adodb.Recordset
Dim db As database, rs As Recordset
Dim strSQLTo As String, strSQLFrom As String, strWhere As String, strUpdateSQL As String
Dim nRecordCount As Long
nRecordCount = SAP_RFC_READ_TABLE_ToAccess(strTableName, "c:\Replicator\" & strTableName & ".accdb", GetFields(strTableName), strOptions)
If nRecordCount > 0 Then
If DCount("[Name]", "MSysObjects", "[Name] = '" & strTableName & "'") = 0 Then
DoCmd.TransferDatabase acLink, "Microsoft Access", "c:\replicator\" & strTableName & ".accdb", acTable, strTableName, strTableName
End If
a = CreateTableSQL(strTableName, False)
SyncronizeData = TransferDataSQL(strTableName, strTableName)
End If
SyncronizeData = nRecordCount
End Function
Function ObjectIsMasterData(strOBJEK As String) As Boolean
Dim objDB As adodb.Connection
Dim objRS As adodb.Recordset
Dim strSQL As String
RetVal = SysCmd(acSysCmdSetStatus, "Checking " & strOBJEK & "...")
ObjectIsMasterData = False
strSQL = "select * from INOB where CUOBJ = '" & strOBJEK & "'"
Set objDB = New adodb.Connection
objDB.CommandTimeout = 0
objDB.ConnectionString = strConnection
objDB.Open
Set objRS = New adodb.Recordset
objRS.Open strSQL, objDB
Do While Not objRS.EOF
If objRS.FIELDS("OBTAB").Value = "MARA" Then
ObjectIsMasterData = True
Exit Do
End If
objRS.MoveNext
Loop
objRS.Close
objDB.Close
Set objRS = Nothing
Set objDB = Nothing
RetVal = SysCmd(acSysCmdClearStatus)
End Function
Function GetFields(strTableName As String) As String
If strTableName = "MARA" Then
GetFields = "MATNR,ERSDA,ERNAM,LAEDA,AENAM,PSTAT,LVORM,MTART,MATKL,MEINS,LABOR,BRGEW,NTGEW,GEWEI,VOLUM,VOLEH,EAN11,NUMTP,PRDHA,VABME,XCHPF,MSTAE,MSTAV,MSTDE,MSTDV,/BAY0/AACGLO,/BAY0/AAUVP"
ElseIf strTableName = "MARC" Then
GetFields = "MATNR,WERKS,PSTAT,MAABC,KZKRI,EKGRP,AUSME,DISMM,DISPO,DISLS,BESKZ,SOBSL,MINBE,EISBE,BSTMI,BSTMA,BSTFE,BSTRF,MABST,SBDKZ,ALTSL,AUSDT,KZBED,FHORI,SSQSS,LADGR,MTVFP,KAUTB,STAWN,HERKL,PRCTR,LOSGR,SOBSK,FRTME,LGPRO,DISGR,KZKUP,LGFSB,SFCPF,MMSTA,MMSTD,NCOST"
ElseIf strTableName = "MVKE" Then
GetFields = "MATNR,VKORG,VTWEG,VERSG,BONUS,PROVG,SKTOF,VMSTA,AUMNG,LFMNG,SCMNG,SCHME,VRKME,MTPOS,DWERK,PRODH,PMATN,KONDM,KTGRM,MVGR1,MVGR2,MVGR3,MVGR4,MVGR5,PRAT1,PRAT2,PRAT3,PRAT4,PRAT5,PRAT6,PRAT7,PRAT8,PRAT9,VAVME,RDPRF"
ElseIf strTableName = "MAKT" Then
GetFields = "MATNR,SPRAS,MAKTX"
ElseIf strTableName = "MBEW" Then
GetFields = "MATNR,BWKEY,BWTAR,LVORM,LBKUM,SALK3,VPRSV,VERPR,STPRS,PEINH,BKLAS,SALKV,VMKUM,VMSAL,VMVPR,VMVER,VMSTP,VMPEI,LPLPR,PSTAT,EKALR,MLAST"
ElseIf strTableName = "KSSK" Then
GetFields = "OBJEK,MAFID,KLART,CLINT,ADZHL,ZAEHL,STATU,STDCL"
ElseIf strTableName = "INOB" Then
GetFields = "CUOBJ,KLART,OBTAB,OBJEK,CLINT,STATU"
ElseIf strTableName = "AUSP" Then
GetFields = "OBJEK,ATINN,ATZHL,MAFID,KLART,ADZHL,ATWRT,ATFLV,ATAWE"
ElseIf strTableName = "MARD" Then
GetFields = "MATNR,WERKS,LGORT"
ElseIf strTableName = "MLGN" Then
GetFields = "MATNR,LGNUM,LVSME"
ElseIf strTableName = "MARM" Then
GetFields = "MATNR,MEINH,UMREZ,UMREN,EANNR,EAN11,NUMTP,LAENG,HOEHE,BREIT,MEABM,VOLUM,VOLEH,BRGEW,GEWEI,MESUB,ATINN"
ElseIf strTableName = "MLAN" Then
GetFields = "MATNR,ALAND,TAXM1,TAXM2,TAXM3"
ElseIf strTableName = "MLGN" Then
GetFields = "MATNR,LGNUM,LVORM,LGBKZ,LTKZE,LTKZA,LVSME"
ElseIf strTableName = "KSML" Then
GetFields = ""
ElseIf strTableName = "KLAH" Then
GetFields = "CLINT,KLART,CLASS,STATU"
ElseIf strTableName = "CABN" Then
GetFields = "ATINN,ADZHL,ATNAM"
ElseIf strTableName = "CABNT" Then
GetFields = "ATINN,SPRAS,ADZHL,ATBEZ"
ElseIf strTableName = "CAWN" Then
GetFields = "ATINN,ATZHL,ADZHL,ATWRT,ATCOD,ATSTD"
ElseIf strTableName = "CAWNT" Then
GetFields = "ATINN,ATZHL,SPRAS,ADZHL,ATWTB"
ElseIf strTableName = "T460A" Then
GetFields = "WERKS,SOBSL,BESKZ"
End If
End Function
Function WaitSeconds(nSeconds As Long, Optional strMessage As String) As Boolean
Dim nSecondsPassed As Long
nSecondsPassed = nSeconds
Do While nSecondsPassed > 0
RetVal = SysCmd(acSysCmdSetStatus, "Resting... " & nSecondsPassed & ", " & strMessage)
nSecondsPassed = nSecondsPassed - 1
Sleep 1000
RetVal = DoEvents
'CurrentData
Loop
RetVal = SysCmd(acSysCmdClearStatus)
End Function
Function CreateTableSQL(strTableName As String, isOverwrite As Boolean) As Boolean
Dim rs As DAO.Recordset, strExecute As String, strKey As String, strDrop As String
Dim nCursec As Integer, nCurrent As Long, strFields As String, nFieldCount As Long
Dim strFieldType As String
'***********************************************
' Find out if this table already exists . . .
'***********************************************
If isOverwrite = False Then
If TableExistsSQL(strTableName) Then
CreateTableSQL = True
Exit Function
End If
End If
RetVal = SysCmd(acSysCmdSetStatus, "Creating table " & strTableName & " . . . ")
strDrop = "IF OBJECT_ID('" & strTableName & "', 'U') IS NOT NULL drop table dbo." & strTableName & ";"
strExecute = ""
strKey = ""
Set rs = CurrentDb.OpenRecordset(strTableName)
nFieldCount = rs.FIELDS.Count
For nCurrent = 0 To nFieldCount - 1
If strFields = "" Then
strFields = rs.FIELDS(nCurrent).Name
Else
strFields = strFields & "," & rs.FIELDS(nCurrent).Name
End If
Next
rs.Close
Set rs = CurrentDb.OpenRecordset("select * from tblDD03L order by POSITION")
Do While Not rs.EOF
If UCase(rs.FIELDS("TABNAME").Value) = UCase(strTableName) Then
If InStr(UCase(strFields), UCase(rs.FIELDS("FIELDNAME").Value)) > 0 Then
If Len(strExecute) > 0 Then
strExecute = strExecute & ","
End If
'strExecute = strExecute & "[" & rs.FIELDS("FIELDNAME").Value & "] nvarchar(" & rs.FIELDS("LENG") & ")"
If rs.FIELDS("DATATYPE").Value = "FLTP" Then
strFieldType = "FLOAT(16)"
Else
strFieldType = "varchar(" & rs.FIELDS("LENG") & ")"
End If
strExecute = strExecute & "[" & rs.FIELDS("FIELDNAME").Value & "] " & strFieldType
If rs.FIELDS("KEYFLAG").Value = "X" Then
If Len(strKey) > 0 Then
strKey = strKey & ","
End If
strKey = strKey & rs.FIELDS("FIELDNAME").Value
End If
End If
End If
If nCursec <> Second(Now) Then
nCursec = Second(Now)
RetVal = DoEvents
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
strExecute = "create table " & strTableName & " (" & strExecute
If strKey <> "" Then
strExecute = strExecute & ", Primary Key (" & strKey & ")"
End If
strExecute = strExecute & ")"
Dim database As adodb.Connection
Set database = New adodb.Connection
With database
.ConnectionString = strConnection
.ConnectionTimeout = 10 'Value is given in seconds.
.Open
End With
If Not database Is Nothing Then
'... Do work.
database.Execute strDrop
database.Execute strExecute
database.Close 'Make sure to close all database connections.
End If
RetVal = SysCmd(acSysCmdClearStatus)
Set database = Nothing
End Function
Function TransferDataSQL(strTableNameAccess As String, strTableNameSQL As String) As Boolean
Dim db As database, rs As Recordset, strSQLTo As String, strSQLFrom As String, strUpdateSet
Dim strExecute As String, strKeys As String, strKeysInsert As String, strDrop As String, strWhereField As String
Dim nCurrentRecord As Long
Dim objDB As adodb.Connection
Dim objRS As adodb.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset(strTableNameAccess)
nFieldCount = rs.FIELDS.Count
For nCurrent = 0 To nFieldCount - 1
If strWhereField = "" Then
strWhereField = rs.FIELDS(nCurrent).Name
End If
If strSQLFrom <> "" Then
strSQLFrom = strSQLFrom & ", "
strSQLTo = strSQLTo & ", "
strUpdateSet = strUpdateSet & ", "
End If
If IsKey(strTableNameSQL, rs.FIELDS(nCurrent).Name) Then
If strKeys <> "" Then
strKeys = strKeys & " AND "
strKeysInsert = strKeysInsert & " AND "
End If
strKeys = strKeys & "toTable.[" & rs.FIELDS(nCurrent).Name & "]=fromTable.[" & rs.FIELDS(nCurrent).Name & "]"
strKeysInsert = strKeysInsert & strTableNameSQL & ".[" & rs.FIELDS(nCurrent).Name & "]=" & strTableNameAccess & ".[" & rs.FIELDS(nCurrent).Name & "]"
strWhereField = rs.FIELDS(nCurrent).Name
End If
strSQLTo = strSQLTo & "[" & rs.FIELDS(nCurrent).Name & "]"
strSQLFrom = strSQLFrom & "fromTable" & ".[" & rs.FIELDS(nCurrent).Name & "]"
strUpdateSet = strUpdateSet & "toTable.[" & rs.FIELDS(nCurrent).Name & "]=fromTable.[" & rs.FIELDS(nCurrent).Name & "]"
Next
Dim database As adodb.Connection
Set database = New adodb.Connection
With database
.ConnectionString = strConnection
.ConnectionTimeout = 0 'Value is given in seconds.
.CommandTimeout = 0
.Open
End With
If Not database Is Nothing Then
'* Following line copies the table from the local system to the SQL Database.
strDrop = "IF OBJECT_ID('tblTemp', 'U') IS NOT NULL drop table dbo.tblTemp;"
database.Execute strDrop
'DoCmd.TransferDatabase acExport, "ODBC Database", "ODBC;" & strConnection, _
' acTable, strTableNameAccess, "tblTemp", False
'Make an empty copy of the target table to temporarily hold the data. It's used instead of
'TransferDatabase acExport becuase it is ten times faster.
'https://stackoverflow.com/questions/61996764/import-from-txt-ms-access-2013-to-sql-server-2016-slow
database.Execute "select * into tblTemp from " & strTableNameSQL & " where " & strWhereField & " is null;"
Set objRS = New adodb.Recordset
objRS.CursorLocation = adUseClient
objRS.Open "tblTemp", database, adOpenForwardOnly, adLockBatchOptimistic
'Set objRS.ActiveConnection = Nothing
rs.MoveLast
rs.MoveFirst
RetVal = SysCmd(acSysCmdInitMeter, "Uploading " & strTableNameSQL & " to SQL Server...", rs.RecordCount)
nCursec = Second(Now())
Do While Not rs.EOF
nCurrentRecord = nCurrentRecord + 1
objRS.AddNew
For nCurrent = 0 To nFieldCount - 1
objRS.FIELDS(rs.FIELDS(nCurrent).Name) = rs.FIELDS(nCurrent).Value
Next
rs.MoveNext
'If nCursec <> Second(Now()) Then
If nCurrentRecord / 500 = Int(nCurrentRecord / 500) Then
'RetVal = DoEvents
'Set objRS.ActiveConnection = database
objRS.UpdateBatch
'Set objRS.ActiveConnection = Nothing
RetVal = SysCmd(acSysCmdUpdateMeter, nCurrentRecord)
RetVal = DoEvents
'nCursec = Second(Now())
End If
Loop
'Set objRS.ActiveConnection = database
objRS.UpdateBatch
objRS.Close
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
strExecute = "MERGE " & strTableNameSQL & " as toTable " & _
"using (select * from tblTemp) as fromTable " & _
"on ( " & strKeys & " )" & _
" WHEN MATCHED THEN UPDATE SET " & strUpdateSet & _
" WHEN NOT MATCHED THEN INSERT (" & strSQLTo & ") VALUES (" & strSQLFrom & ");"
'* Next line copies the data from the Access table (that was just copied to the SQL server).
database.Execute strExecute
database.Close 'Make sure to close all database connections.
RetVal = SysCmd(acSysCmdRemoveMeter)
End If
Set database = Nothing
Set objRS = Nothing
Set objDB = Nothing
RetVal = SysCmd(acSysCmdClearStatus)
End Function
Function IsKey(strTableName, strFieldName) As Boolean
Static nKeys As Long, strFields(99999, 2) As String
Dim db As database, rs As Recordset, nCurrent As Long
Dim isFound As Boolean
IsKey = False
isFound = False
For nCurrent = 1 To nKeys
If strFields(nCurrent, 0) = strTableName Then
isFound = True
If strFields(nCurrent, 1) = strFieldName Then
If strFields(nCurrent, 2) = "X" Then
IsKey = True
End If
Exit Function
End If
End If
Next
If isFound Then
'This field isn't in the table . . .
Exit Function
End If
RetVal = SysCmd(acSysCmdSetStatus, "Caching fields for " & strTableName & " . . . ")
RetVal = DoEvents
Set db = CurrentDb
Set rs = db.OpenRecordset("tblDD03L") 'No need to sort.
Do While Not rs.EOF
If rs.FIELDS("TABNAME").Value = strTableName Then
nKeys = nKeys + 1
strFields(nKeys, 0) = rs.FIELDS("TABNAME").Value
strFields(nKeys, 1) = rs.FIELDS("FIELDNAME").Value
strFields(nKeys, 2) = rs.FIELDS("KEYFLAG").Value & ""
If strFields(nKeys, 1) = strFieldName Then
If strFields(nKeys, 2) = "X" Then
IsKey = True
End If
End If
End If
rs.MoveNext
If nCursec <> Second(Now) Then
nCursec = Second(Now)
RetVal = DoEvents
End If
Loop
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
RetVal = SysCmd(acSysCmdClearStatus)
End Function
Function isAlreadyLoaded(strTableName As String, strSQL As String) As Boolean
Dim objDB As adodb.Connection
Dim objRS As adodb.Recordset
'Dim db As DAO.database, rs As DAO.Recordset
'Set db = CurrentDb
RetVal = SysCmd(acSysCmdSetStatus, "Checking " & strSQL & "...")
RetVal = DoEvents
If TableExistsSQL(strTableName) Then
Set objDB = New adodb.Connection
objDB.CommandTimeout = 0
objDB.ConnectionString = strConnection
objDB.Open
Set objRS = New adodb.Recordset
objRS.Open strSQL, objDB
Do While Not objRS.EOF
isAlreadyLoaded = True
objRS.MoveNext
Loop
objRS.Close
objDB.Close
Else
isAlreadyLoaded = False
End If
Set objRS = Nothing
Set objDB = Nothing
RetVal = DoEvents
RetVal = SysCmd(acSysCmdClearStatus)
End Function
Function TableExistsSQL(strTableName As String) As Boolean
Dim objDB As adodb.Connection
Dim objRS As adodb.Recordset
Set objDB = New adodb.Connection
objDB.CommandTimeout = 0
objDB.ConnectionString = strConnection
objDB.Open
Set objRS = New adodb.Recordset
objRS.Open "select * from INFORMATION_SCHEMA.tables", objDB
Do While Not objRS.EOF
If objRS.FIELDS("TABLE_NAME").Value = strTableName Then
TableExistsSQL = True
End If
objRS.MoveNext
Loop
objRS.Close
objDB.Close
Set objRS = Nothing
Set objDB = Nothing
End Function
Function SAP_RFC_READ_TABLE_ToAccess(strSAPTable As String, strFileName As String, strFields As String, Optional ByVal strOptions As String = "") As Long
Dim strTemp As String
Dim strOptions2 As String
strOptions2 = strOptions
'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 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
' 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
Dim BAPIRET2 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
'***********************************
' Set up an offset and length loop.
'***********************************
Const nMaxRowCount = 2000000
Dim nRowSkip
nRowSkip = 0
nTotalSeconds = 0
RetVal = SysCmd(acSysCmdSetStatus, "Connecting to " & R3.Connection.System & " . . . ")
If R3.Connection.IsConnected < 1 Then
If Not GetR3(R3) Then
Exit Function
End If
End If
nCurrent = R3.Connection.IsConnected
'*****************************************************
'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 = ""
ROWSKIPS.Value = nRowSkip
ROWCOUNT.Value = nMaxRowCount
'Quebrando o nome dos campos
j = 0
FIELDS.Rows.RemoveAll
If strFields <> "" Then
strFieldNames = Split(strFields, ",")
For Each vField In strFieldNames
j = j + 1
FIELDS.Rows.Add
FIELDS.Value(j, "FIELDNAME") = Trim(UCase(vField))
Next
Else
For nCurrent = 1 To 999
strRow = strRow & ","
Next
strFieldNames = Split(strRow, ",")
End If
'Quebrando Lendo condições Where
j = 0
OPTIONS.Rows.RemoveAll
If strOptions <> "" Then
stroption = UCase(strOptions)
'If InStr(strOptions, " OR ") Then
' strConvOptions = Split(strOptions, " OR ")
Do While Len(strOptions) > 0
For nCurrent = 1 To Len(strOptions)
If Right(Left(strOptions, nCurrent), 5) = " AND " Then
OPTIONS.Rows.Add
j = j + 1
OPTIONS.Value(j, 1) = Left(strOptions, nCurrent)
strOptions = Mid(strOptions, nCurrent + 1, 99999)
Exit For
ElseIf Right(Left(strOptions, nCurrent), 4) = " OR " Then
If nCurrent > 35 Then
OPTIONS.Rows.Add
j = j + 1
OPTIONS.Value(j, 1) = Left(strOptions, nCurrent)
strOptions = Mid(strOptions, nCurrent + 1, 99999)
Exit For
End If
Else
If nCurrent = Len(strOptions) Then
'This is the last Option.
OPTIONS.Rows.Add
j = j + 1
OPTIONS.Value(j, 1) = strOptions
strOptions = ""
End If
End If
Next
Loop
End If
RetVal = SysCmd(acSysCmdSetStatus, "Extracting from table " & strSAPTable & " to " & strFileName & " . . . ")
Result = MyFunc.Call
If Result = True Then
Set DATA = MyFunc.Tables("DATA")
Set FIELDS = MyFunc.Tables("FIELDS")
Set OPTIONS = MyFunc.Tables("OPTIONS")
Else
Set BAPIRET2 = MyFunc.Tables("RETURN")
'MsgBox MyFunc.EXCEPTION
strOptions = MyFunc.exception
a = WaitSeconds(100, strOptions)
Set MyFunc = Nothing
Set DATA = Nothing
Set FIELDS = Nothing
Set OPTIONS = Nothing
'R3.Connection.logoff
'Set R3 = Nothing
RetVal = SysCmd(acSysCmdClearStatus)
Err.Raise 666, strOptions, "SAP threw a lame error. Call back to error handler."
Exit Function
End If
nTotalColumns = FIELDS.ROWCOUNT
'Create the Access Database (strFileName).
'*******************************************
If Len(Dir(strFileName)) > 0 Then
Kill strFileName
End If
Dim accessApp As Access.Application
Set accessApp = New Access.Application
accessApp.DBEngine.CreateDatabase strFileName, DB_LANG_GENERAL
accessApp.Quit
Set accessApp = Nothing
Set dbs = OpenDatabase(strFileName)
Set tdf = dbs.CreateTableDef(strSAPTable)
nRowCount = FIELDS.ROWCOUNT
For iField = 1 To nRowCount
fName = FIELDS(iField, "FIELDNAME")
fType = dbText
fSize = FIELDS(iField, "LENGTH") 'nSizes(nCounter) 'fSize = 255
Set fld1 = tdf.CreateField(fName, fType, fSize)
fld1.AllowZeroLength = True
fld1.Required = False
tdf.FIELDS.Append fld1
If strFieldName <> "" Then
strFieldName = strFieldName & ","
End If
strFieldNames(iField - 1) = FIELDS(iField, "FIELDNAME") 'Used later . . .
Next
dbs.TableDefs.Append tdf
dbs.TableDefs.Refresh
dbs.Close
Set dbs = Nothing
'Open the newly created table in the newly created database.
'***********************************************************
Set dbs = OpenDatabase(strFileName)
Set rs = dbs.OpenRecordset(strSAPTable)
'Class this function up a little...
RetVal = SysCmd(acSysCmdClearStatus)
RetVal = SysCmd(acSysCmdInitMeter, "Importing " & strTableName & " from SAP...", DATA.ROWCOUNT)
iField = 1
For iField = 1 To nRowCount
nFieldData(iField, 1) = FIELDS(iField, "OFFSET")
nFieldData(iField, 2) = FIELDS(iField, "LENGTH")
Next
Do While DATA.ROWCOUNT > 0
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 " & strSAPTable & " from " & R3.Connection.System & " to " & strFileName & ". [" & nTotalRecords & " of " & DATA.ROWCOUNT + nRowSkip & "]", DATA.ROWCOUNT)
RetVal = SysCmd(acSysCmdUpdateMeter, iRow)
RetVal = DoEvents()
'rs.Update 'Commit writes each second.
End If
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(strFieldNames(iField - 1)).Value = Trim(Mid(strRow, nFieldData(iField, 1) + 1, nFieldData(iField, 2)))
Next
rs.Update
Next
'* Free up some memory.
RetVal = SysCmd(acSysCmdRemoveMeter)
RetVal = SysCmd(acSysCmdInitMeter, "Cleaning up memory from extracting " & strSAPTable & ". [" & nTotalRecords & " of " & DATA.ROWCOUNT + nRowSkip & "]", DATA.ROWCOUNT)
RetVal = SysCmd(acSysCmdUpdateMeter, iRow)
RetVal = DoEvents()
MyFunc.Tables("DATA").Rows.RemoveAll 'Special thanks to Mike Burnett
'***********************************************************
' Check to see if the function should be called again . . .
'***********************************************************
If DATA.ROWCOUNT < nMaxRowCount Then
'There is no need to read again to get a zero value.
Exit Do
Else
'Set the offset to read the next block.
nRowSkip = nRowSkip + nMaxRowCount
End If
'***********************************************************
' Call the function again to get the next block of records.
'***********************************************************
ROWSKIPS.Value = nRowSkip
ROWCOUNT.Value = nMaxRowCount
Result = MyFunc.Call
Set DATA = MyFunc.Tables("DATA")
Set FIELDS = MyFunc.Tables("FIELDS")
Set OPTIONS = MyFunc.Tables("OPTIONS")
Loop
rs.Close
dbs.Close
Set rs = Nothing
Set dbs = Nothing
RetVal = SysCmd(acSysCmdRemoveMeter)
'*****************************************
' Log off of the SAP system and clean up.
'*****************************************
Set DATA = Nothing
Set FIELDS = Nothing
Set OPTIONS = Nothing
Set MyFunc = Nothing
Set QUERY_TABLE = Nothing
Set DELIMITER = Nothing
Set NO_DATA = Nothing
Set ROWSKIPS = Nothing
Set ROWCOUNT = Nothing
Set dbs = Nothing
Set tdf = Nothing
Set fld1 = Nothing
'R3.Connection.logoff
'Set R3 = Nothing
SAP_RFC_READ_TABLE_ToAccess = nTotalRecords
End Function
Function RemoveTableDuplicates(strTableName As String) As Boolean
Dim dbs As DAO.database
Dim rs As DAO.Recordset
Dim nCurrent As Long, nFieldCount As Long, nRecordCount As Long
Dim RetVal As Variant, nCurRec As Long, dnow As Date, nCursec As Long
Dim nTotalSeconds As Long, nSecondsLeft As Long
Dim strtest As String, strLastRecord As String, strThisRecord As String
Dim strSQL As String, nTotalDeleted As Long
Set rs = CurrentDb.OpenRecordset(strTableName)
nFieldCount = rs.FIELDS.Count
Rem **** Build Query ****
strSQL = "SELECT * FROM " & strTableName & " ORDER BY "
For nCurrent = 0 To rs.FIELDS.Count - 1
strSQL = strSQL & rs.FIELDS(nCurrent).Name
If nCurrent < rs.FIELDS.Count - 1 Then
strSQL = strSQL & ", "
End If
Next
strSQL = strSQL & ";"
rs.Close
Set rs = CurrentDb.OpenRecordset(strSQL)
nRecordCount = rs.RecordCount
RetVal = SysCmd(acSysCmdInitMeter, "Removing duplicates from " & strTableName & ". . .", nRecordCount)
Do While Not rs.EOF
nCurRec = nCurRec + 1
If Second(Now()) <> nCursec And nCurRec <> rs.RecordCount Then
nCursec = Second(Now())
RetVal = SysCmd(acSysCmdUpdateMeter, nCurRec)
RetVal = DoEvents()
End If
strThisRecord = ""
For nCurrent = 0 To rs.FIELDS.Count - 1
strThisRecord = strThisRecord & rs.FIELDS(nCurrent).Value
Next
If StrComp(strThisRecord, strLastRecord, 0) = 0 Then
rs.Delete
nTotalDeleted = nTotalDeleted + 1
If nTotalDeleted / 1000 = Int(nTotalDeleted / 1000) Then
rs.Close
Set rs = CurrentDb.OpenRecordset(strSQL)
rs.MoveFirst
'Technically starting over, but not completely.
nCurRec = nRecordCount - rs.RecordCount
End If
End If
strLastRecord = strThisRecord
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
RemoveTableDuplicates = True
RetVal = SysCmd(acSysCmdRemoveMeter)
End Function
Function ToSAPDate(dDate As Date) As String
ToSAPDate = Year(dDate) & Right("00" & Month(dDate), 2) & Right("00" & Day(dDate), 2)
End Function
Credit where it is due
Developing this tool was an exciting learning experience for this humble programmer. I list two very important sources that saved me hours of fighting with a corporate laptop and SQL.
This article and the code written herein required a small crash course on SQL Server's permissions and networking which were provided concisely by this video by Carlo Capello. In this video, Carlo touches on two key issues that were an impasse for hours: SQL Server authentication and TCP Ports and for that, he is showered with special thanks.
Special thanks also to Arshad Ali for this very well written article that allowed for a thourogh understanding of the MERGE command in Microsoft SQL. It allows for a cumbersome combination of UPDATE and INSERT commands using outer joins to be replaced by a clean, eloquent snippet of SQL to do both.
