GUI Scripting 12 - Extract Large Tables

' SAP GUI Scripting Exercise
' This file is provided as is. Please use and modify it for your own use.
' Check out my playlist of SAP GUI Scripting related videos:
' https://www.youtube.com/watch?v=oPPhA14Pm-8&list=PLk9erb9HGsPh28DftWcP8BIXmBtu2wnsL
'
'This example shows how to extract data from large tables such as BKPF and mergeing the result into a large list in Excel
'
' Cheers, Csongor

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 W_System
Private LogCount As Integer
Public shScript, shLog As Worksheet

' -------------------------------------------------------------------
' This method cycles through all open GUI sessions and finds the
' first matching the SID+Client stored in the Excel
' -------------------------------------------------------------------
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

' -----------------------------------------------------------
' Running the actula GUI script for the active line in the Excel
' -----------------------------------------------------------
Public Sub RunGUIScript(currentline As Integer)

Dim W_Ret As Boolean
Dim Filename As String
Dim Folder As String

W_Ret = Attach_Session
If Not W_Ret Then
    Exit Sub
End If

' Filename will be row id, so it will start with export_0010
Filename = "export_" & Right("00000" & currentline, 4) & ".txt"
'Get the same folder
Folder = Range("Folder").Value

On Error GoTo myerr

AddLog "Extract", "Extracting file " + Filename, vbBlack
objSess.findById("wnd[0]").maximize
objSess.findById("wnd[0]/tbar[0]/okcd").Text = "/nse16"
objSess.findById("wnd[0]").sendVKey 0
objSess.findById("wnd[0]/usr/ctxtDATABROWSE-TABLENAME").Text = "bkpf"
objSess.findById("wnd[0]").sendVKey 0
objSess.findById("wnd[0]/usr/ctxtI1-LOW").Text = Cells(currentline, 1).Value
objSess.findById("wnd[0]/usr/ctxtI5-LOW").Text = Replace(Cells(currentline, 2).Value, "-", "/")
objSess.findById("wnd[0]/usr/ctxtI5-HIGH").Text = Replace(Cells(currentline, 3).Value, "-", "/")
objSess.findById("wnd[0]/usr/ctxtLIST_BRE").Text = "1250"
objSess.findById("wnd[0]/usr/txtMAX_SEL").Text = "100000"
objSess.findById("wnd[0]/usr/txtMAX_SEL").SetFocus
objSess.findById("wnd[0]/usr/txtMAX_SEL").caretPosition = 10
objSess.findById("wnd[0]").sendVKey 0
objSess.findById("wnd[0]/tbar[1]/btn[8]").press
objSess.findById("wnd[0]/tbar[0]/okcd").Text = "%pc"
objSess.findById("wnd[0]").sendVKey 0
objSess.findById("wnd[1]/tbar[0]/btn[0]").press
objSess.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = Filename
objSess.findById("wnd[1]/usr/ctxtDY_PATH").Text = Folder
objSess.findById("wnd[1]/tbar[0]/btn[11]").press

AddLog "Extract", "Extracted " + Filename, vbBlack
' Setting the line status to completed
Cells(currentline, 4).Value = 1
Exit Sub

myerr:
' Some error occured
' Setting the line status to Failed
Cells(currentline, 4).Value = 2
AddLog "Extract", "Failed " + Filename, vbRed

End Sub


Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
Set fso = CreateObject("Scripting.FileSystemObject")

If FolderExists(path) Then
    Exit Function
Else
    On Error GoTo DeadInTheWater
    fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
    Exit Function
End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

FolderExists = False
Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FolderExists(path) Then FolderExists = True

End Function

' -------------------------------------------------------------
' Load the extract generated by SE16 to Excel
' -------------------------------------------------------------
Function OpenExtract(Filename As String) As Boolean
'
' Load the SE16 extract
'
'
On Error GoTo myerr
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & Filename, Destination:=Range("$A$1"))
        .Name = "export"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 4
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(9, 9, 9, 1, 1, 1, 1, 4, 4, 1, 4, 1, 4, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
        , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileDecimalSeparator = ","
        .TextFileThousandsSeparator = "."
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    OpenExtract = True
    Exit Function
myerr:
    OpenExtract = False
End Function

' ---------------------------------------------------------------
' Copy the loaded extract from the temp sheet and add to the end of the list
' on the Export sheet
' ---------------------------------------------------------------
Function CopyOver(currentline As Integer) As Boolean
'
'
Dim tempmax As Long
Dim extractmax As Long
'
On Error GoTo myerr

    ' If this is the first line, copy the headers over
    If currentline = 10 Then
        Sheets("temp").Select
        Rows("1:1").Select
        Selection.Copy
        Sheets("Export").Select
        Rows("1:1").Select
        ActiveSheet.Paste
    End If

    Sheets("temp").Select
    'Find the last line in the temp sheet
    tempmax = 3
    While Cells(tempmax, 1).Value <> ""
        tempmax = tempmax + 1
    Wend
    tempmax = tempmax - 1

    Rows("3:" & tempmax).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Export").Select

    ' Find the last line in the extract sheet
    extractmax = 2
    While Cells(extractmax, 1).Value <> ""
        extractmax = extractmax + 1
    Wend

    Rows(extractmax & ":" & extractmax).Select
    ActiveSheet.Paste

    CopyOver = True
    Exit Function
myerr:
    CopyOver = False
End Function

' ----------------------------------------------------------------
' The entire extraction routine which calls the GUI script for each line
' runs the extract and after loades and summarizes the data into Excel
' ----------------------------------------------------------------
Sub StartExtract()
Dim currentline As Integer
Dim Filename As String


    If MsgBox("Make sure you delete any old extracts from folder " & Range("Folder").Value, vbOKCancel, "Delete old data") = vbCancel Then
        Exit Sub
    End If

    'Set the defaults
    W_System = Range("System").Value
    Set shScript = Worksheets("Script")
    ResetLog

    Sheets("Export").Select
    DeleteAll
    Sheets("Script").Select

    ' First create the download all the table entries one-by-one
    currentline = 10
    While Cells(currentline, 1).Value <> ""
        RunGUIScript currentline
        ' move to the next line
        currentline = currentline + 1
    Wend

    ' Process all the extracted data
    Application.Calculation = xlCalculateManual
    currentline = 10
    While Cells(currentline, 1).Value <> ""
        Sheets("temp").Select
        DeleteAll
        Filename = Range("Folder").Value + "\export_" & Right("00000" & currentline, 4) & ".txt"
        AddLog "Load", "Loading file " + Filename, vbBlack
        ' Load the extract to the temp sheet
        If OpenExtract(Filename) Then
            AddLog "Load", "Loaded " + Filename, vbBlack
            ' Clean up any columns that are required
            ' Uncomment the next line to trim all cells (for trailing spaces)
            ' Trimall
            ' Use the below line to trim only a selected column
            TrimColumn 20
            If CopyOver(currentline) Then
                AddLog "Copy", "Copy data over done", vbBlack
            Else
                AddLog "Copy", "Copy data over failed", vbRed
            End If
        Else
            AddLog "Load", "Failed to load " + Filename, vbRed
        End If

        Sheets("Script").Select
        ' move to the next line
        currentline = currentline + 1
    Wend
    Application.Calculation = xlCalculationAutomatic
    ' Update the current date and time
    Sheets("Script").Select
    Cells(2, 2).Value = Now()
    objSess.EndTransaction
    MsgBox "Script completed"

End Sub

Sub ResetLog()
    'This function deleted the current log and resets some values

    Dim LastRow As Integer

    Set shLog = Worksheets("Log")
    LogCount = 0
    shLog.Select
    'Find the last row in the sheet
    LastRow = shLog.UsedRange.Rows(shLog.UsedRange.Rows.Count).row
    If LastRow < 3 Then LastRow = 3
    Rows("3:" + CStr(LastRow)).Select
    Selection.Delete Shift:=xlUp
    Range("A3").Select
    shScript.Select
End Sub

Sub AddLog(id As String, message As String, color As Integer)
    'New line is added to the log
    shLog.Cells(LogCount + 3, 1).Font.color = color
    shLog.Cells(LogCount + 3, 2).Font.color = color
    shLog.Cells(LogCount + 3, 1) = id
    shLog.Cells(LogCount + 3, 2) = message

    'Add borders to the new cells
    shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlDiagonalDown).LineStyle = xlNone
    shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlDiagonalUp).LineStyle = xlNone
    With shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With shLog.Range("A" + CStr(LogCount + 3) + ":B" + CStr(LogCount + 3)).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With


    LogCount = LogCount + 1
End Sub

Sub DeleteAll()
'
' DeleteAll Macro
'

'
    On Error Resume Next
    Cells.Select
    Selection.QueryTable.Delete
    Selection.ClearContents
    Range("A1").Select
End Sub

Sub TrimAll()
Dim row As Integer
Dim col As Integer

row = 3
col = 1

On Error Resume Next
While Cells(row, col).Value <> ""
    While Cells(row, col).Value <> ""
        Cells(row, col).Value = Trim(Cells(row, col).Value)
        col = col + 1
    Wend
    row = row + 1
    col = 1
Wend

Range("A1").Select
End Sub

Sub TrimColumn(col As Integer)
Dim row As Integer

row = 3

On Error Resume Next
While Cells(row, col).Value <> ""
    Cells(row, col).Value = Trim(Cells(row, col).Value)
    row = row + 1
Wend

Range("A1").Select
End Sub