SAP_ECC.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SAPECC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'{F9} - Jump to first form value

'F1 - Documentation
'F2
'F3 - Back button  (Can exit to home, or jump back, disables on home page)
'F4 - Find objects in Classes (probably just a IH06 thing)
'F5
'F6
'F7
'F8 - Execute search
'F9 - Background print parameters (might differ between forms)
'F10
'F11 - Jump to Save as variant mmenu
'F12 - Cancel ( Can exit to home, or jump back, disables on home page)

'+F1 - Programmer documentation
'+F3 - Exit    Can exit to home OR Log off (if at home already)
'
'+F5 - Jump to Go to... Variant menu
'+F10 - Right click on current focussed item

'Alt F12 Open "Customise Local Layout" menu i.e. menu with abap debugger in

'USING SLEEP FOR CONSISTENCY
'--------------------------------------------------------------------------------------------------
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If
'--------------------------------------------------------------------------------------------------

'FOR USING SEND MESSAGE TO SEND KEYSTROKES
'--------------------------------------------------------------------------------------------------
#If VBA7 Then
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#Else
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If
Const WM_KEYDOWN As Long = &H100
Const WM_KEYUP As Long = &H100
Const VK_RETURN As Long = &HD
Const VK_EXECUTE As Long = &H2B
'--------------------------------------------------------------------------------------------------

'FOR FOCUSSING SAP WINDOW WHILE SENDING KEYS
'--------------------------------------------------------------------------------------------------
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
'--------------------------------------------------------------------------------------------------

'FOR FINDING WINDOWS BY CAPTION
'--------------------------------------------------------------------------------------------------
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'--------------------------------------------------------------------------------------------------

'## REQUIRES: stdAcc

'Workbook containing SAP data to close on cleanup
Private wb As Workbook
Private bLaunched As Boolean

Public zpIE As Object
Public zpHwndIE As LongPtr
Public zpAccMain As stdAcc
Public zpAccSAPMain As stdAcc
Public zpAccToolbar As stdAcc
Public zpAccTransaction As stdAcc
Public zpAccErrBar As stdAcc

Const ECC_URL As String = "YOUR_INTERNET_EXPLORER_SAP_LINK"

Public Function Create() As SAPECC
  Set Create = New SAPECC
  Call Create.Init
End Function
Public Sub Init()
  'Create Internet Explorer object
  On Error GoTo IELaunchError
      Dim iTry As Long
      iTry = 0
      Set zpIE = CreateObject("InternetExplorer.Application")
      zpIE.Visible = True
  On Error GoTo 0
  
  'Navigate to SAP ECC
  Call zpIE.navigate(ECC_URL)
  
  'Wait for IE to finish loading
  Do While zpIE.ReadyState = 4: DoEvents: Loop
  Do While zpIE.ReadyState <> 4: DoEvents: Loop
  
  'Sleep 2 second just to ensure no reloads occur
  Call Sleep(500)
  
  'initialize protected properties
  zpHwndIE = zpIE.hwnd
  Set zpAccMain = stdAcc.FromHwnd(zpHwndIE)
  
  'When accessing the accessibility model of SAP, for whatever reason when
  'straying beyond a certain depth, the structure changes meaning that the main sap window swaps from
  '4.5.4.1 to 4.5.4.2. Thus we first obtain a handle to 4.5.4.1.1
  Call zpAccMain.FromPath("4.5.4.1.1")
  
  'Get SAP Main
  Set zpAccSAPMain = zpAccMain.FromPath("4.5.4.2.4.1.4.1.1.2.1.1.1.1.4.1.4.1.4")
  
  'Optimised AccToolbar and AccTransaction bar search:
  With zpAccSAPMain
    Set zpAccToolbar = .FromPath(".7.4")
    Set zpAccTransaction = .FromPath(".2.4.1.4")
    Set zpAccErrBar = .FromPath(".8.4")
  End With
  
  bLaunched = True
  Exit Sub
IELaunchError:
  If Err.Description Like "*A system shutdown has already been scheduled*" Then
      'Try 3 times to create IE object
      If iTry < 3 Then
          iTry = iTry + 1
          Call Sleep(300)
          Resume
      End If
  End If

ErrGetData:
  MsgBox Err.Description, vbCritical
  End
End Sub


Public Property Get Launched() As Boolean
  Launched = bLaunched
End Property

Public Property Get Transaction() As String
  Transaction = zpAccTransaction.value
End Property
Public Property Let Transaction(ByVal sTransactId As String)
  zpAccTransaction.value = sTransactId
  Call SendKeys("{ENTER}", zpAccTransaction.hwnd)
End Property
Public Property Get TransactionField() As stdAcc
    Set TransactionField = zpAccTransaction
End Property
Public Property Get ErrorText() As String
    ErrorText = zpAccErrBar.name
End Property

Public Function AwaitToolbarName(ByVal sName As String) As stdAcc
  'Wait till name is visible (on the toolbar)
  While True
    'Check all buttons for the name sName, and return if found
    Dim button As stdAcc
    For Each button In zpAccToolbar.children
        If button.name = sName Then
            Set AwaitToolbarName = button.children(4)
            Exit Function
        End If
    Next
    
    DoEvents
  Wend
End Function
Public Function AwaitToolbarNameOrError(ByVal sName As String) As stdAcc
  Dim iStartTime As Long: iStartTime = GetTickCount()
  
  'Wait till name is visible (on the toolbar)
  While True
    'Increment counter
    iCount = iCount + 1
    
    'Check all buttons for the name sName, and return if found
    Dim button As stdAcc
    For Each button In zpAccToolbar.children
        If button.name = sName Then
            Set AwaitToolbarNameOrError = button.children(4)
            Exit Function
        End If
    Next
    
    'Initiate error check if after half a second since start
    Dim iDiff As Long: iDiff = Abs(GetTickCount() - iStartTime)
    If iDiff >= 500 Then
        'Check for error information, if found then return nothing
        If Me.ErrorText <> "" Then
            Set AwaitToolbarNameOrError = Nothing
            Exit Function
        End If
    End If
    DoEvents
  Wend
End Function

Public Sub cmdExecute(Optional ByVal sKey As String = "F8")
  Call SendKeys("{" & sKey & "}", zpHwndIE)
End Sub
Public Sub cmdBack()
  Call SendKeys("{F3}", zpHwndIE)
End Sub
Public Sub cmdExit()
  Call SendKeys("+{F3}", zpHwndIE)
End Sub
Public Sub cmdCancel()
  Call SendKeys("{F12}", zpHwndIE)
End Sub
Public Sub cmdHome()
  Call SendKeys("{F12 10}", zpHwndIE)
End Sub
Public Sub cmdTab(Optional ByVal iTimes As Long = 1)
  Call SendKeys("{TAB " & iTimes & "}", zpHwndIE)
End Sub
Public Sub FocusToolbar()
  Dim button As stdAcc
  Set button = zpAccToolbar.children(1)
  button.Focus = True
End Sub
Public Sub CopyPasteFieldValue(ByVal sText As String)
  'Set clipboard to value
  stdClipboard.Text = sText
  
  'Paste value in field
  Call SendKeys("^a", zpHwndIE)
  Call SendKeys("^v", zpHwndIE)
End Sub
Public Function CopySelected(Optional ByVal sSelectAllKeys As String = "^a") As String
    'Set clipboard to blank
    stdClipboard.Text = ""
    
    'Copy text
    Call Me.SendKeys(sSelectAllKeys)
    Call Me.SendKeys("^c")
    Call Me.Wait(200) 'time for copy to register
    
    'Return data
    CopySelected = stdClipboard.Text
End Function
Public Sub SendKeysMain(ByVal sKeys As String)
  Call SendKeys(sKeys, zpHwndIE)
  Call Sleep(200)
End Sub
Public Sub SendKeysRawMain(ByVal sKeys As String)
  Call SendKeysRaw(sKeys, zpHwndIE)
  Call Sleep(200)
End Sub


Public Sub Wait(ByVal iMilliseconds As Long)
  Call Sleep(iMilliseconds)
End Sub
Public Function AwaitSAPWindow(ByVal sName As String) As stdAcc
  Dim wnd As Object
  While wnd Is Nothing
      Set wnd = GetSapWindowID(sName)
      DoEvents
  Wend
  Set AwaitSAPWindow = stdAcc.FromHwnd(wnd!hwnd)
End Function
Public Sub Quit()
  zpIE.Quit
End Sub



Private Function getSAPWorkbook(Optional ByVal sQuery As String = "*RIIFLO20*") As Workbook
    'Get sap workbook into private wb
    Set wb = Nothing
    While wb Is Nothing
        Set wb = pGetSAPWorkbook(sQuery)
        DoEvents
    Wend
    Set getSAPWorkbook = wb
End Function

'Supply a set of keys, and an optional window ID. If a window is provided then,
'this window will be forced to the top. Then keys will be sent to the active window using WScript.Shell
'Special keys can be sent like {Down} {Up} {Enter} {Backspace} etc.
'+ Indicates shift, ^ represents ctrl, % represents alt, ~ represents {Enter}
'Keys can be held down as follows {SHIFT DOWN}, {SHIFT UP}
'@param {ByVal String} - Keys to send.
'@param {Opt ByVal Long} - Window to send keys to.
'KeyList:
'   BACKSPACE       {BACKSPACE}, {BS}, or {BKSP}
'   BREAK           {BREAK}
'   CAPS LOCK       {CAPSLOCK}
'   DEL or DELETE   {DELETE} or {DEL}
'   END             {END}
'   ENTER           {ENTER} or ~
'   ESC             {ESC}
'   HELP            {HELP}
'   HOME            {HOME}
'   INS or INSERT   {INSERT} or {INS}
'   UP ARROW        {UP}
'   DOWN ARROW      {DOWN}
'   LEFT ARROW      {LEFT}
'   RIGHT ARROW     {RIGHT}
'   NUM LOCK        {NUMLOCK}
'   PAGE DOWN       {PGDN}
'   PAGE UP         {PGUP}
'   PRINT SCREEN    {PRTSC}
'   SCROLL LOCK     {SCROLLLOCK}
'   TAB             {TAB}
'   F1              {F1}
'   F2              {F2}
'   F3              {F3}
'   F4              {F4}
'   F5              {F5}
'   F6              {F6}
'   F7              {F7}
'   F8              {F8}
'   F9              {F9}
'   F10             {F10}
'   F11             {F11}
'   F12             {F12}
'   F13             {F13}
'   F14             {F14}
'   F15             {F15}
'   F16             {F16}
Public Sub SendKeys(ByVal sKeys As String, Optional ByVal toWindow As Long = 0)
    On Error GoTo ErrOccurred
    Static oShell As Object: If oShell Is Nothing Then Set oShell = CreateObject("WScript.Shell")
    If toWindow > 0 Then
        Call ForceWindowToTop(toWindow)
    End If
    Call oShell.SendKeys(sKeys)
    Exit Sub
ErrOccurred:
    Debug.Assert False
End Sub

'Similar to SendKeys, however all special characters are removed.
Public Function SendKeysRaw(ByVal sKeys As String, Optional ByVal toWindow As Long = 0)
    'https://ss64.com/vb/sendkeys.html
    On Error GoTo ErrOccurred
    Static oShell As Object: If oShell Is Nothing Then Set oShell = CreateObject("WScript.Shell")
    sKeys = Replace(sKeys, "{", "{{}")
    sKeys = Replace(sKeys, "}", "{}}")
    sKeys = Replace(sKeys, "[", "{[}")
    sKeys = Replace(sKeys, "]", "{]}")
    sKeys = Replace(sKeys, "+", "{+}")
    sKeys = Replace(sKeys, "^", "{^}")
    sKeys = Replace(sKeys, "~", "{~}")
    sKeys = Replace(sKeys, "!", "{!}")
    sKeys = Replace(sKeys, "%", "{%}")
    
    
    
    If toWindow > 0 Then
        Call ForceWindowToTop(toWindow)
    End If
    Call oShell.SendKeys(sKeys)
    Exit Function
ErrOccurred:
    Debug.Assert False
End Function

'Obtain the hWND of a window with the caption/title sCaption
'@param {ByVal String} sCaption - Text to find in window title/caption
'@returns {Long} hWND of window found
Private Function GetWindowID(ByVal sCaption As String) As Long
    GetWindowID = FindWindow(vbNullString, sCaption)
End Function

'Obtain a SAP window hwnd by it's name
'@param {ByVal String} - Name of window to find
'@returns {Dictionary} Dictionary containing hwnd, window class, window name, window visibility, window position, window size, window pID and window pName
'@example: GetSapWindowID("Excel: Number of Key Columns")
Private Function GetSapWindowID(ByVal sCaption As String) As Object
    'Get all pids
    Set pids = GetPIDs("saplogon.exe")
    
    'If nothing then quit
    If pids Is Nothing Then Exit Function
    
    'Get windows by pids
    Set x = GetWindowsByPids(pids)
    
    'If nothing then quit
    If x Is Nothing Then Exit Function
    
    'Find window based on caption
    For Each wnd In x
        'Debug.Print wnd!Name
        If wnd!name = sCaption Then
            Set GetSapWindowID = wnd
        End If
    Next
End Function

'Given a process name obtain the process IDs from winmgmts
'@param {ByRef String} - Process name
'@returns {Dictioanry} - Dictionary containing process IDs as keys and values
Private Function GetPIDs(sName As String) As Object
    Dim wmi As Object
    Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
    Set procs = wmi.ExecQuery("Select handle from Win32_Process where name=""" & sName & """")
    
    
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    
    Dim proc As Object
    For Each proc In procs
        d(proc.Handle) = proc.Handle
    Next
    
    Set GetPIDs = d
End Function

'Force the window specified by the hWND supplied to the top/front
'@param {ByVal Long} hWND of window to make active
Private Sub ForceWindowToTop(ByVal hwnd As Long)
    Dim lMyPId As Long
    Dim lCurPId As Long
    Dim Handle As Long
    Handle = GetForegroundWindow()
    lMyPId = GetWindowThreadProcessId(hwnd, 0)
    lCurPId = GetWindowThreadProcessId(Handle, 0)
    
    If Not (lMyPId = lCurPId) Then
        AttachThreadInput lCurPId, lMyPId, True
        SetForegroundWindow hwnd
        AttachThreadInput lCurPId, lMyPId, False
    End If
    
    If Not (GetForegroundWindow() = hwnd) Then
        SetForegroundWindow hwnd
    End If
End Sub

'Find and return the workbook who's name is RIIFLO20
Private Function pGetSAPWorkbook(ByVal sQuery As String) As Workbook
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.name Like sQuery Then
            Set pGetSAPWorkbook = wb
            Exit Function
        End If
    Next
End Function

Private Sub Class_Terminate()
  On Error Resume Next
  Me.Quit
End Sub