使用VBA代码从SAP导出Excel仅在逐步执行时有效

时间:2019-07-15 06:46:49

标签: excel vba sap

所以我的主要问题是我有一个代码来使用SSO打开SAP和SAP窗口,执行SAP脚本,将报告导出为Excel表格(此后它会自动打开excel),然后关闭导出的Excel -片。在调试器中逐步执行时,代码工作得很好。当我以正常模式处理代码时,脚本完成后它将停止,并且excel应该打开(在调用CloseExcel函数之前)。如果您可以看一下我的代码并提供我所缺少的一些知识,那将是很好的。我很感谢每一个提示。

我已经用wscript.sleep和application.wait命令对其进行了测试。我也尝试拆分宏,但似乎没有任何效果。

Option Explicit
'here are some public variables which i use in more than one sub
Dim W_System
Public SapGuiAuto, WScript, msgcol
Public objGui  As GuiApplication
Public objConn As GuiConnection
Public objSess As GuiSession
Public objSBar As GuiStatusbar
Public objSheet As Worksheet
Dim Path$, Dataname$


'Here I run all macros at once (later I want to run everything with a button)

Sub Execute()
'My SAP System SYSID "HE5", Mandant "100"
W_System = "HE5100"

    SAP1

    application.Wait (Now + TimeValue("00:00:05"))

    SAP2

    objSess.EndTransaction


End Sub

Sub SAP1()

'Here are some variables i need in this code

Dim WSHShell As Object
Dim WScript, SAPGUIPath, Instanz, WinTitel, SapGuiAuto, application, connection, session, Name


  On Error Resume Next

    If Not IsObject(application) Then

      Set SapGuiAuto = GetObject("SAPGUI")

        If Err.Number <> 0 Then

  Set WSHShell = CreateObject("WScript.Shell")
  If IsObject(WSHShell) Then

'Here I open the SAP and a SAP window

    SAPGUIPath = "C:\Program Files (x86)\SAP\FrontEnd\SAPgui\"
    Name = """Enterprise PROD SYSS"""
    Instanz = "00"

    WSHShell.Exec SAPGUIPath & "sapgui.exe " & Name & " " & _
      Instanz


    Set WSHShell = Nothing

  End If

On Error GoTo 0

                  Else

         On Error GoTo 0
        End If
    End If

    On Error Resume Next


        If Not IsObject(connection) Then

Set connection = application.Children(0)

          If Err.Number <> 0 Then

'msgbox open another SAP window

          Else

            On Error GoTo 0

            End If


Set connection = application.Children(0)

      End If


End Sub

'With this function I connect to the SAP window so I can execute the Script
Function Attach_Session() As Boolean
Dim il, it
Dim W_conn, W_Sess

If W_System = "" Then
   Attach_Session = False
   Exit Function
End If

If Not objSess Is Nothing Then
    If objSess.Info.SystemName & objSess.Info.Client = W_System Then
        Attach_Session = True
        Exit Function
    End If
End If

If objGui Is Nothing Then
   Set SapGuiAuto = GetObject("SAPGUI")
   Set objGui = SapGuiAuto.GetScriptingEngine
End If

For il = 0 To objGui.Children.Count - 1
    Set W_conn = objGui.Children(il + 0)
    For it = 0 To W_conn.Children.Count - 1
        Set W_Sess = W_conn.Children(it + 0)
        If W_Sess.Info.SystemName & W_Sess.Info.Client = W_System Then
            Set objConn = objGui.Children(il + 0)
            Set objSess = objConn.Children(it + 0)
            Exit For
        End If
    Next
Next

If objSess Is Nothing Then
   MsgBox "No active session to system " + W_System + ", or scripting is not enabled.", vbCritical + vbOKOnly
   Attach_Session = False
   Exit Function
End If

If IsObject(WScript) Then
   WScript.ConnectObject objSess, "on"
   WScript.ConnectObject objGui, "on"
End If

Set objSBar = objSess.findById("wnd[0]/sbar")
objSess.findById("wnd[0]").maximize
Attach_Session = True


End Function

Sub SAP2()

Dim W_Ret As Boolean
Dim actualdate As Date
Dim Version As Byte


      ' Connect to SAP
  W_Ret = Attach_Session
  If Not W_Ret Then
  Exit Sub
  End If

      'Get variables for the script

      Worksheets("Parameter").Activate
      actualdate = Cells(1, 2)
      Version = Cells(3, 2)
      Path = Cells(5, 2)
      Dataname = Cells(6, 2)


      On Error GoTo myerr

      'Insert SCRIPT HERE

      With objSess

      .findById("wnd[0]").maximize
      .findById("wnd[0]/tbar[0]/okcd").Text = "s_alr"
      .findById("wnd[0]").SendVKey 0
      .findById("wnd[0]/tbar[1]/btn[17]").press
      .findById("wnd[0]/usr/ctxtBERDATUM").Text = actualdate
      .findById("wnd[0]/usr/ctxtBEREICH1").Text = Version
      .findById("wnd[0]/usr/ctxtBEREICH1").SetFocus
      .findById("wnd[0]/usr/ctxtBEREICH1").caretPosition = 2
      .findById("wnd[0]/tbar[1]/btn[8]").press
      .findById("wnd[0]/tbar[1]/btn[33]").press
      .findById("wnd[1]/usr/lbl[1,7]").SetFocus
      .findById("wnd[1]/usr/lbl[1,7]").caretPosition = 7
      .findById("wnd[1]").SendVKey 2
      .findById("wnd[1]/tbar[0]/btn[0]").press
      .findById("wnd[0]/mbar/menu[0]/menu[1]/menu[1]").Select
      .findById("wnd[1]/tbar[0]/btn[0]").press
      .findById("wnd[1]/usr/ctxtDY_PATH").Text = Path
      .findById("wnd[1]/usr/ctxtDY_FILENAME").Text = Dataname & ".xlsx"
      .findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 9
      .findById("wnd[1]/tbar[0]/btn[11]").press

      End With
      'I found this function from a different thread but it seems it doesnt work for me in normal mode 

      Call CloseExcel(Dataname & ".xlsx")

      Exit Sub

myerr:
      MsgBox "Error occured while retrieving data", vbCritical + vbOKOnly

      End Sub

Sub CloseExcel(Optional ByVal archiv As String)
   Dim wshell
   Dim xclapp, xclsheet, xclwbk

   On Error Resume Next
   Set wshell = CreateObject("WScript.Shell")
   Do
    Err.Clear
    Set xclapp = GetObject(, "Excel.Application")
    If Err.Number = 0 Then Exit Do
    DoEvents


    WScript.sleep 2000
    Loop

   Do
    Err.Clear
    Set xclwbk = xclapp.Workbooks.Item(archiv)
    If Err.Number = 0 Then Exit Do
    DoEvents

    WScript.sleep 2000
    Loop

   On Error GoTo 0
   Set xclsheet = xclwbk.Worksheets(1)

   xclapp.Visible = True
   xclapp.DisplayAlerts = False

   xclapp.ActiveWorkbook.Close

   Set xclwbk = Nothing
   Set xclsheet = Nothing
   End Sub

作为输出,我希望通过普通模式运行宏,并在最后关闭excel工作表。此刻脚本之后停止(没有错误消息,在按export excel按钮后,该脚本仍在运行,但没有任何结果,并且excel宏挂断了。)

0 个答案:

没有答案