|
Vb codes (or VBA macro code) for access SAP, and run one RFC |
Views: 1125
|
Thread Tools | Rate Thread |
#1
|
|||
|
|||
Vb codes (or VBA macro code) for access SAP, and run one RFC
Vb codes (or VBA macro code) for access SAP, and run one RFC
I can give you some code, but not sure it will work for you. 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 |