"Vb codes (or VBA macro code) for access SAP, and run
one RFC
When you ( or the help desk ) installs the SAP GUI, you
can also install the SAP RFC development kit, if you do this you will have in
your c:\program files\SAP??? ( in my case C:\Program Files\SAP620 ) a folder
with a .frm extension
( in my case C:\Program Files\SAP620 \SAPGUI\rfcsdk\ccsamp\RFCSamp.VB\RFCsamp.frm
)
From there you can start then, because you also need
the vbp file and the vbw file in order to really make it work. If you just need
the code, then here you go :
Option Explicit
Private Sub Command1_Click()
'Dim Foo As RFCSampObj ' Due to an acknowledged problem in MTS
Dim Foo As Object ' we Dim Foo as Object instead of as RFCSampObj
Dim searchterm As String
Dim custlist As Recordset
Set Foo = CreateObject("RFCSampObj.RFCSampObj.1")
Foo.Destination = "IDES"
'Foo.Client = "800"
'Foo.Language = "E"
'Foo.UserID = "test"
'Foo.Password = "pw"
If Not Foo Is Nothing Then
searchterm = Text1.Text
'Unfortunately RFC_CUSTOMER_GET does not convert
' a SPACE selction into a * so we do it here....
If IsEmpty(searchterm) Then searchterm = "*"
On Error Resume Next
Call Foo.GetCustList(searchterm, "", custlist)
If Err.Number = 0 Then
If Not custlist Is Nothing Then
custlist.MoveFirst
While Not custlist.EOF
Debug.Print "------------------"
Debug.Print "custlist.Fields(name1) " &
custlist.Fields("NAME1")
Debug.Print "custlist.Fields(stras) " &
custlist.Fields("STRAS")
Debug.Print "custlist.Fields(ort01) " &
custlist.Fields("ORT01")
Debug.Print "custlist.Fields(pstlz) " &
custlist.Fields("PSTLZ")
Debug.Print "custlist.Fields(telf1) " &
custlist.Fields("TELF1")
Debug.Print "custlist.Fields(telfx) " &
custlist.Fields("TELFX")
custlist.MoveNext
Wend
Else
Debug.Print "ERROR: custlist is Nothing"
End If
Else
Debug.Print "ERROR" & Err.Description
MsgBox Err.Description, vbCritical, "Error:"
End If
Else
Debug.Print "Foo is nothing"
MsgBox "Foo is nothing"
End If
End Sub
Private Sub Command2_Click()
'Dim Foo As RFCSampObj ' Due to an acknowledged problem in MTS
Dim Foo As Object ' we Dim Foo as Object instead of as RFCSampObj
Dim rs As Recordset
Dim HeaderIn As Recordset
Dim ItemsIn As Recordset
Dim Partners As Recordset
Dim OrderNumber As String
Dim BapiReturn As Recordset
Dim SoldTo As Recordset
Dim ShipTo As Recordset
Dim Payer As Recordset
Dim ItemsOut As Recordset
'Input tables can be crafted in two different ways:
' - either using the DimAsXXXX method which returns a fully
' described but empty Recordset.
' - or using the AdvancedDataFactory to craft up a disconnected
' Recordset.
' An example of the later is shown with the Partners Table
' the remaining input tables are crafted with the dim as.
Dim adf As Object
' Describe the shape of a disconnected recordset
Dim vrsShape(1)
Dim vrsParvw(3)
Dim vrsKunnr(3)
vrsParvw(0) = "PARTN_ROLE"
vrsParvw(1) = CInt(8)
vrsParvw(2) = CInt(2)
vrsParvw(3) = False
vrsKunnr(0) = "PARTN_NUMB"
vrsKunnr(1) = CInt(8)
vrsKunnr(2) = CInt(10)
vrsKunnr(3) = False
vrsShape(0) = vrsParvw
vrsShape(1) = vrsKunnr
' Create a disconnected recordset to pass as an input
Set adf = CreateObject("RDSServer.DataFactory")
If adf Is Nothing Then
MsgBox "ADF == NOTGHING"
End If
Set Partners = adf.CreateRecordSet(vrsShape)
Set Foo = CreateObject("RFCSampObj.RFCSampObj.1")
If Not Foo Is Nothing Then
' Get an empty recordset which will be used as input in
CreateOrder call
Call Foo.DimHeader(HeaderIn)
HeaderIn.AddNew
HeaderIn.Fields("DOC_TYPE") = "TA"
HeaderIn.Fields("SALES_ORG") = "1000"
HeaderIn.Fields("DISTR_CHAN") = "10"
HeaderIn.Fields("DIVISION") = "00"
HeaderIn.Fields("PURCH_NO") = "SM-1177-3"
HeaderIn.Fields("INCOTERMS1") = "CPT"
HeaderIn.Fields("INCOTERMS2") = "Hamburg"
HeaderIn.Fields("PMNTTRMS") = "ZB01"
HeaderIn.Update
Call Foo.DimItems(ItemsIn)
ItemsIn.AddNew
ItemsIn.Fields("MATERIAL") = "R-1120"
ItemsIn.Fields("PLANT") = "1200"
ItemsIn.Fields("REQ_QTY") = 2000
ItemsIn.Update
Partners.AddNew
Partners.Fields("PARTN_ROLE") = "AG"
Partners.Fields("PARTN_NUMB") = "0000001177"
Partners.Update
'set logon information
Foo.Destination = "IDES"
'Foo.Client = "800"
'Foo.Language = "E"
'Foo.UserID = "test"
'Foo.Password = "pw"
Call Foo.OrderCreate(HeaderIn, _
ItemsIn, _
Partners, _
OrderNumber, _
SoldTo, _
ShipTo, _
Payer, _
ItemsOut, _
BapiReturn)
Debug.Print "OrderNumber" & OrderNumber
If BapiReturn Is Nothing Then
MsgBox "BapiReturn is Nothing"
Else
BapiReturn.MoveFirst
Debug.Print "BapiReturn.Type...." & BapiReturn.Fields("TYPE")
Debug.Print "BapiReturn.Code...." & BapiReturn.Fields("CODE")
Debug.Print "BapiReturn.Message." & BapiReturn.Fields
("MESSAGE")
Debug.Print "BapiReturn.LogNo..." & BapiReturn.Fields
("LOG_NO")
Debug.Print "BapiReturn.LogMsgNo" & BapiReturn.Fields
("LOG_MSG_NO")
End If
Else
MsgBox "Foo is nothing"
End If
End Sub
Private Sub Command3_Click()
'Dim Foo As RFCSampObj ' Due to an acknowledged problem in MTS
Dim Foo As Object ' we Dim Foo as Object instead of as RFCSampObj
Dim SalesOrders As Recordset
Dim BapiReturn As Recordset
Set Foo = CreateObject("RFCSampObj.RFCSampObj.1")
If Not Foo Is Nothing Then
'set logon information
Foo.Destination = "IDES"
'Foo.Client = "800"
'Foo.Language = "E"
'Foo.UserID = "test"
'Foo.Password = "pw"
On Error Resume Next
Call Foo.GetCustomerOrders(CustomerNumber.Text, _
SalesOrg.Text, _
, , , , _
BapiReturn, _
SalesOrders)
If Err.Number = 0 Then
If Not SalesOrders Is Nothing Then
SalesOrders.MoveFirst
While Not SalesOrders.EOF
Debug.Print "------------------"
Debug.Print "SalesOrders.Fields(SD_DOC).... " &
SalesOrders.Fields("SD_DOC")
Debug.Print "SalesOrders.Fields(ITM_NUMBER) " &
SalesOrders.Fields("ITM_NUMBER")
Debug.Print "SalesOrders.Fields(MATERIAL).. " &
SalesOrders.Fields("MATERIAL")
Debug.Print "SalesOrders.Fields(REQ_QTY)... " &
SalesOrders.Fields("REQ_QTY")
Debug.Print "SalesOrders.Fields(NAME)...... " &
SalesOrders.Fields("NAME")
Debug.Print "SalesOrders.Fields(NET_VALUE). " &
SalesOrders.Fields("NET_VALUE")
Debug.Print "SalesOrders.Fields(PURCH_NO).. " &
SalesOrders.Fields("PURCH_NO")
SalesOrders.MoveNext
Wend
Else
Debug.Print "ERROR: SalesOrders is Nothing"
End If
If BapiReturn Is Nothing Then
MsgBox "BapiReturn is Nothing"
Else
BapiReturn.MoveFirst
Debug.Print "BapiReturn.Type...." & BapiReturn.Fields
("TYPE")
Debug.Print "BapiReturn.Code...." & BapiReturn.Fields
("CODE")
Debug.Print "BapiReturn.Message." & BapiReturn.Fields
("MESSAGE")
Debug.Print "BapiReturn.LogNo..." & BapiReturn.Fields
("LOG_NO")
Debug.Print "BapiReturn.LogMsgNo" & BapiReturn.Fields
("LOG_MSG_NO")
End If
Else
Debug.Print "ERROR"
MsgBox Err.Description, vbCritical, "Error:"
End If
Else
MsgBox "Foo is nothing"
End If
End Sub
