关于VB下载SAP文档的代码

以下代码也只是试验品，仅供参考，但是经过实验是可以下载文件的。

 

SAP FM：ZDOWNLOAD_DOC_FROM_OUTSIDE（RFC）

该函数作用是可以得到文档附件对应的16进制

FUNCTION ZDOWNLOAD_DOC_FROM_OUTSIDE.
*"----------------------------------------------------------------------
*"*"Local interface:
*"  IMPORTING
*"     VALUE(IM_DOKAR) TYPE  DRAW-DOKAR
*"     VALUE(IM_DOKNR) TYPE  DRAW-DOKNR
*"     VALUE(IM_DOKVR) TYPE  DRAW-DOKVR
*"     VALUE(IM_DOKTL) TYPE  DRAW-DOKTL
*"     VALUE(ORIGINALPATH) TYPE  FILEP DEFAULT 'C:\'
*"  EXPORTING
*"     VALUE(SIZE) TYPE  INT4
*"     VALUE(MIMETYPE) TYPE  W3CONTTYPE
*"  TABLES
*"      DATA_TAB STRUCTURE  SDOKCNTBIN
*"----------------------------------------------------------------------
  DATA:LT_FILES  TYPE BAPI_DOC_FILES2 OCCURS 0 WITH HEADER LINE.
  DATA:LT_INFO   TYPE SCMS_ACINF      OCCURS 0 WITH HEADER LINE.

  CALL FUNCTION 'BAPI_DOCUMENT_GETDETAIL2'
    EXPORTING
      DOCUMENTTYPE    = IM_DOKAR
      DOCUMENTNUMBER  = IM_DOKNR
      DOCUMENTPART    = IM_DOKTL
      DOCUMENTVERSION = IM_DOKVR
      GETACTIVEFILES  = 'X'
      GETDOCFILES     = 'X'
    TABLES
      DOCUMENTFILES   = LT_FILES.
  IF SY-SUBRC = 0.
    READ TABLE LT_FILES INDEX 1.
    IF SY-SUBRC = 0.
      CALL FUNCTION 'SCMS_DOC_READ'
        EXPORTING
          STOR_CAT    = LT_FILES-STORAGECATEGORY
          DOC_ID      = LT_FILES-FILE_ID
        TABLES
          ACCESS_INFO = LT_INFO
          CONTENT_BIN = DATA_TAB.
      READ TABLE LT_INFO INDEX 1.
      IF SY-SUBRC = 0.
        SIZE = LT_INFO-COMP_SIZE.
        MIMETYPE = LT_INFO-MIMETYPE.
      ENDIF.
    ENDIF.
  ENDIF.
ENDFUNCTION.

 

VB部分：

Option Explicit
Dim oDoc As DOMDocument
Dim DOCINPATH As String
Dim XMLOUTPATH As String
Dim DOCOUTPATH As String
Private arry() As Byte
Private Declare Function RfcAllowStartProgram Lib "librfc32" (ByVal RAccess As String) As Integer
Private Sub Command1_Click()
   
    Dim RETURNCODE As Integer
    RETURNCODE = RfcAllowStartProgram("sapftp;saphttp")
    download
End Sub

 

Private Sub download()
       
    Dim R3     As Object
    Dim Sap    As Object
    Dim MyFunc As Object
   
    Dim table  As Object
    Dim buffer As String
    Dim size   As Long
    Dim mimetype   As String
    Dim i      As Long
   
    Dim count  As Long
     
    Set R3 = CreateObject("SAP.Functions")
    Set Sap = R3.Connection
   
    Sap.ApplicationServer = "***"
    Sap.Client = "***"
    Sap.User = "***"
    Sap.Password = "***"
    Sap.Language = "ZH"
      
    If Sap.Logon(0, True) = True Then
       Set MyFunc = R3.Add("ZDOWNLOAD_DOC_FROM_OUTSIDE")
       MyFunc.exports("IM_DOKAR") = "ST4"
       MyFunc.exports("IM_DOKNR") = "TCD00000001366"
       MyFunc.exports("IM_DOKTL") = "000"
       MyFunc.exports("IM_DOKVR") = "-"
       MyFunc.exports("ORIGINALPATH") = "C:\"

       If MyFunc.Call = True Then

          Set table = MyFunc.Tables("data_tab")
          size = MyFunc.imports("size")
          mimetype = MyFunc.imports("mimetype")
          buffer = ""
         
          count = 2044 - (table.rowcount * 2044 - size * 2)
          For i = 1 To table.rowcount
              If i < table.rowcount Then
                  buffer = buffer & table(i, "line")
              Else
                  buffer = buffer & Left(table(i, "line"), count)
              End If
          Next
         
          arry = buffer
         

''通过XML方式转化16进制并生成文件
          Call cmdCreateXML_Click
          Call cmdGetBinary_Click
         
       Else
           MsgBox "调用RFC出错,请联系作者!"
           Unload Me
       End If
    Else
       MsgBox "登陆到SAP失败!"
    End If
   
    Sap.Logoff
    
    Set table = Nothing
    Set MyFunc = Nothing
    Set R3 = Nothing
    Set Sap = Nothing
   
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' How to create XML with binary data
'
' General program flows:
'
' Build  builds a small XML file from a MS Doc file
' Write  saves XML tree to a file
' Write the MS Doc file as another file
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Use the version dependent progid DOMDocument40 to create an MSXML 4.0 DOMDocument object if your are referencing MSXML 4.0 in your project.

 

Private Sub cmdCreateXML_Click()
   
    Dim oEle As IXMLDOMElement
    Dim oRoot As IXMLDOMElement
    Dim oNode As IXMLDOMNode
   
    DOCINPATH = App.Path & "\DocInput.doc"
    XMLOUTPATH = App.Path & "\XmlOuput.xml"
         
    Call ReleaseObjects
   
    Set oDoc = New DOMDocument
    oDoc.resolveExternals = True
   
' Create processing instruction and document root
    Set oNode = oDoc.createProcessingInstruction("xml", "version='1.0'")
    Set oNode = oDoc.insertBefore(oNode, oDoc.childNodes.Item(0))
   
' Create document root
    Set oRoot = oDoc.createElement("Root")
    Set oDoc.documentElement = oRoot
    oRoot.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"

   
    Set oNode = oDoc.createElement("Data")
    oRoot.appendChild oNode
    Set oEle = oNode
   
' Use DataType so MSXML will validate the data type
    oEle.dataType = "bin.hex"
    
' Read in the data
    oEle.Text = arry
   
    oDoc.Save XMLOUTPATH
   
  
End Sub

Function ReadBinData(ByVal strFileName As String) As Variant
    Dim lLen As Long
    Dim ifile As Integer
    Dim arrBytes() As Byte
    Dim lCount As Long
    Dim strOut As String
   
'Read from disk
    ifile = FreeFile()
    Open strFileName For Binary Access Read As ifile
    lLen = FileLen(strFileName)
    ReDim arrBytes(lLen - 1)
    Get ifile, , arrBytes
    Close ifile
   
    ReadBinData = arrBytes
End Function

Private Sub WriteBinData(ByVal strFileName As String)
    Dim ifile As Integer
    Dim arrBuffer() As Byte
    Dim oNode As IXMLDOMNode
     
    If Not (oDoc Is Nothing) Then
       
' Get the data
        Set oNode = oDoc.documentElement.selectSingleNode("/Root/Data")

' Make sure you use a byte array instead of variant
        arrBuffer = oNode.nodeTypedValue
           
' Write to disk
       
        ifile = FreeFile()
        Open strFileName For Binary Access Write As ifile
        Put ifile, , arrBuffer
        Close ifile
   
    End If
   
End Sub

Private Sub cmdGetBinary_Click()
       
    DOCOUTPATH = App.Path & "\DocOutput.doc"
   
    Set oDoc = New DOMDocument
   
    If oDoc.Load(XMLOUTPATH) = True Then
       ' Save the Doc as another file
       WriteBinData DOCOUTPATH
      
       MsgBox DOCOUTPATH & " is created for you."
    Else
        MsgBox oDoc.parseError.reason
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ReleaseObjects
End Sub

Private Sub ReleaseObjects()
    Set oDoc = Nothing
End Sub