SAP GUI Scripting Sample

loader.bas

Attribute VB_Name = "SapScripting"
Option Explicit
Public Function SAP_GetSession(sName As String) As Object
'
' Get existing SAP session by system name
'
    Dim SapApplication As Object
    Dim SapGuiAuto As Object
    Dim SapConnection As Object
    Dim SapSession As Object
    Dim i As Integer
    
    ' Initialize SAP GUI Scripting API
    On Error Resume Next
    Set SapGuiAuto = GetObject("SAPGUI")
    On Error GoTo 0
    If Not SapGuiAuto Is Nothing Then
        Set SapApplication = SapGuiAuto.GetScriptingEngine
    End If
    
    ' Connect to the system
    If Not SapApplication Is Nothing Then
        If SapApplication.Children.Length > 0 Then
            For i = 0 To SapApplication.Children.Length - 1
                Set SapConnection = SapApplication.Children(i + 0) '(i+0) is SAP magic
                If SapConnection.Description = sName Then
                    Exit For 'select the first session with correct name
                Else
                    Set SapConnection = Nothing
                End If
            Next i
        End If
    End If
    
    ' Get the GuiSession object
    If Not SapConnection Is Nothing Then
        For i = SapConnection.Children.Length - 1 To 0 Step -1
            If Not SapConnection.Children(i + 0).Busy _
            Or i = 0 Then
                Set SapSession = SapConnection.Children(i + 0)
                Do While SapSession.Info.Program <> "SAPLSMTR_NAVIGATION" _
                And SapSession.Info.Transaction <> "SMEN"
                    SapSession.EndTransaction
                    If SapSession.Info.Transaction = "S000" _
                    Or SapSession.Info.Program = "SAPMSYST" Then
                        'handle login page
                        Set SapSession = Nothing
                        Exit Do
                    End If
                Loop
                Exit For
            End If
        Next i
    End If
    
    Set SAP_GetSession = SapSession
    If SAP_GetSession Is Nothing Then
        MsgBox "Невозможно подключиться к """ & sName & """" & vbNewLine _
                & vbNewLine & "Проверьте, выполнен ли вход в систему.", _
                Buttons:=vbCritical, Title:="Ошибка"
    End If
End Function

worker.bas

Attribute VB_Name = "Sap4T"
Option Explicit



Public Function v4T_export(Optional ByRef oSession As Object = Nothing, _
                           Optional ByVal sDir As String = "", _
                           Optional ByVal sPeriod As String = "", _
                           Optional ByVal bShort As Boolean = False, _
                           Optional ByVal bLong As Boolean = False, _
                           Optional ByVal bSh As Boolean = False, _
                           Optional ByVal bShCh As Boolean = False)
'
'Export 1-K(DR) reports
'
    Dim arOptions
    Dim bCumulative
    Dim i
    Dim arRP
    Dim bInteractive As Boolean
    Dim fInput As f_Sap1KDR
    arRP = Array("QL49", "QL51", "QL52", "QL53", "QL75", _
                 "QL59", "QL65", "QL66", "QL67", "QL74", _
                 "QL54", "QL56", "QL57", "QL61", "QL62", _
                 "QL64", "QL68", "QL69", "QL73", "QL76", _
                 "QL70", "QL72", "QL58", "QL60")
                       
    If oSession Is Nothing Then
        Set oSession = SAP_GetSession("003. ЕК АСУТР")
    End If
    
    bInteractive = (sDir = "") Or _
                   (sPeriod = "") Or _
                   Not (bShort Or bLong) Or _
                   Not (bSh Or bShCh)
    
    If Not oSession Is Nothing Then
        If bInteractive Then
            Set fInput = New f_Sap1KDR
            fInput.Report = "4-Т"
            fInput.Show 'get user input via the form
            On Error Resume Next
            Err.Clear
            If Not fInput.Valid Then Exit Function
            If Not Err.Number = 0 Then Exit Function
            On Error GoTo 0
            
            sDir = fInput.Directory
            sPeriod = fInput.Year & "." & fInput.Month
            bShort = fInput.ShortPeriod
            bLong = fInput.LongPeriod
            bSh = fInput.Sh
            bShCh = fInput.ShCh
            
            Unload fInput
        End If
        
        If Right(sDir, 1) <> Application.PathSeparator Then
            sDir = sDir & Application.PathSeparator
        End If
        
        If Len(sDir) > 128 - (9 + 6 + 4) Then '128: SAP limit; 9+6+4: filename
            MsgBox "Слишком длинный путь к файлу", vbCritical + vbOKOnly, "Ошибка"
            Exit Function
        End If
        
        If CInt(Right(sPeriod, 2)) = 1 Then
            bShort = True
            bLong = False
        End If
        
        If bShort And bLong Then
            arOptions = Array(True, False)
        ElseIf bShort Then
            arOptions = Array(False)
        ElseIf bLong Then
            arOptions = Array(True)
        Else
            Exit Function
        End If
        
        If Not bSh And Not bShCh Then Exit Function
        
        'Worker
        For Each bCumulative In arOptions
            If bSh Then
                Call v4T_run(oSession, sDir, sPeriod, arRP, CBool(bCumulative))
            End If
            If bShCh Then
                For Each i In arRP
                    Call v4T_run(oSession, sDir, sPeriod, Array(i), CBool(bCumulative))
                Next i
            End If
        Next bCumulative
    End If
End Function





Private Function v4T_run(ByRef oSession As Object, _
                         ByVal sDir As String, _
                         ByVal sPeriod As String, _
                         ByVal arRP As Variant, _
                         Optional ByVal bLongPeriod As Boolean = False)
'
'1-К(ДР)
'
    Const sFilename As String = "4-Т"
    Const sTransaction As String = "Y_DHR_72000024"
    Const sBE As String = "5067"
    
    Dim sStartDate As String
    Dim i
    Dim num As Integer
    Dim sPrefix As String
    Dim sName As String
    Dim sNewFilename As String
    Dim sFullPath As String
    Dim sTmp
    Dim ErrNum(1 To 3) As Long
    Dim sOEsingle As String
    Dim bSingle(2 To 3) As Boolean
        
    'workaround for "Waiting for OLE" interrupting message
    Dim bAlerts As Boolean
    bAlerts = Application.DisplayAlerts
    Application.DisplayAlerts = False

    oSession.LockSessionUI
    
    oSession.StartTransaction (sTransaction)
    With oSession.findById("wnd[0]")
        'initial parameters
        If bLongPeriod Then
            sStartDate = MonthFirstDay(Left(sPeriod, 5) & "01")
            sPrefix = "нар"
        Else
            sStartDate = MonthFirstDay(sPeriod)
            sPrefix = ""
        End If
        
        .findById("usr/radPNPTIMR6").Select
        .findById("usr/ctxtPNPBEGDA").Text = sStartDate
        .findById("usr/ctxtPNPENDDA").Text = MonthLastDay(sPeriod)
        .findById("usr/chkSHOW_NPF").Selected = True
        .findById("usr/chkSPLT_VAC").Selected = True
        .findById("usr/chkSPLT_N70").Selected = True
        .findById("usr/chk97_ACCNT").Selected = True
        .findById("usr/ctxtPNPBUKRS-LOW").Text = sBE
        
        On Error Resume Next
        sOEsingle = CStr(arRP) 'test for string
        ErrNum(1) = Err.Number
        Err.Clear
        bSingle(2) = UBound(arRP) = LBound(arRP) 'test for array
        ErrNum(2) = Err.Number
        Err.Clear
        bSingle(3) = arRP.Count = 1 'test for collection
        ErrNum(3) = Err.Number
        Err.Clear
        On Error GoTo 0
        
        If ErrNum(1) = 0 Then 'type 8204 is a result of array function
            .findById("usr/ctxtPNPWERKS-LOW").Text = sOEsingle
        ElseIf ErrNum(2) = 0 And bSingle(2) Then
            .findById("usr/ctxtPNPWERKS-LOW").Text = arRP(UBound(arRP))
        ElseIf ErrNum(3) = 0 And bSingle(3) Then
            .findById("usr/ctxtPNPWERKS-LOW").Text = arRP.Item(1)
        Else
            .findById("usr/ctxtPNPWERKS-LOW").SetFocus
            Call ArrayToClipboard(arRP)
            .findById("usr/btn%_PNPWERKS_%_APP_%-VALU_PUSH").press
            oSession.findById("wnd[1]/tbar[0]/btn[24]").press
            .SendVKey 8
        End If
        
        .SendVKey 8 'execute (F8)
        .SendVKey 0 'enter
    End With
    num = 0
    If UBound(arRP) = LBound(arRP) Then
        sName = arRP(LBound(arRP))
    Else
        sName = CStr(UBound(arRP) - LBound(arRP) + 1) & "дист"
    End If
    sNewFilename = sPeriod & sPrefix & " " & sName & " " & sFilename
    
    'Export to plain text
    With oSession.findById("wnd[0]")
        .findById("mbar/menu[0]/menu[1]/menu[2]").Select 'export to the text file
    End With
    With oSession.findById("wnd[1]")
        .findById("usr/sub:SAPLSPO5:0101/radSPOPLI-SELFLAG[0,0]").Select
        .findById("tbar[0]/btn[0]").press
    End With
    With oSession.findById("wnd[1]")
        .findById("usr/ctxtDY_PATH").Text = sDir
        .findById("usr/ctxtDY_FILENAME").Text = "t" & sNewFilename & ".txt"
        .findById("tbar[0]/btn[11]").press
    End With
    
    'Export to excel (max full path length is 128 characters)
    With oSession.findById("wnd[0]")
        .findById("mbar/menu[0]/menu[1]/menu[2]").Select 'export
    End With
    With oSession.findById("wnd[1]")
        .findById("usr/sub:SAPLSPO5:0101/radSPOPLI-SELFLAG[4,0]").Select
        .findById("tbar[0]/btn[0]").press
    End With
    With oSession.findById("wnd[1]")
        .findById("usr/chkSCR-EXEC").Selected = False
        
        sTmp = CStr(sDir & _
                    "" & sNewFilename & ".xls")
        If Len(sTmp) <= 128 Then
            sFullPath = sTmp
        Else
            sFullPath = sDir & Application.PathSeparator & _
                   sPeriod & Left(sPrefix, 1) & " " & sName & ".xls"
            If Len(sFullPath) > 128 Then
                Err.Raise 5201, , "Слишком длинный путь к файлу:" & vbNewLine & sFullPath
                Exit Function
            End If
        End If
            
        .findById("usr/ctxtSCR-FNAME").Text = sFullPath
        .findById("tbar[0]/btn[0]").press
        .SendVKey 0 'enter
        .SendVKey 0 'enter
    End With
    
    'clean up
    Application.DisplayAlerts = bAlerts
    oSession.UnlockSessionUI
End Function





Public Sub v4T_BatchExport()
'
'One-time batch export. Lots of hardcoded constants!
'
    Dim m, n
    Dim sP, sD
    
    Const sDestination As String = "D:\Выгрузки из программы\4-Т\"
    For m = 2012 To 2014
        For n = 1 To 12
            If Not (m = 2012 And n < 10) Then
                sP = m & "." & Format(n, "00")
                sD = sDestination & sP & " закрытый\"
                Call v4T_export(sDir:=sD, _
                                sPeriod:=sP, _
                                bShort:=True, _
                                bLong:=True, _
                                bSh:=True, _
                                bShCh:=True)
            End If
        Next n
    Next m
End Sub