VBA - API Call issues with Show Window Activation

[Goose306]

Hi all,

I have a fairly complicated issue here I hope someone may be able to help me on. Essentially, what I'm doing is pushing an automated email out every week or so that is ran via VBScript and Task Scheduler. However, I have to work around various corporate Group Policy IT issues. Thus, I have to rely on SendKeys (yuck) to actually mail the message. Here's where I am so far:

• Programmed in controls to handle the sending of the message using .Display, and hotkeys (ALT+S). Also scripted in controls to handle the auto spell-check and confirmation dialog (also controlled via Group Policy, otherwise I'd just disable it.)

The issue comes when running the VBS with no files/Outlook open, which is imperative as this is a Task Manager script and will need to run while my profile is logged off. When ran off VBS, it appears to run, however I can't get the Outlook email message to take focus (and then fire off the Sendkeys). I've programmed an API call to user32 to find the window and activate it, which works when the macro is fired from the Excel pick list, but not when ran off the VBS. It appears the API won't allow the window to take focus if another window (EX: the Explorer window I have open to click the VBS) has focus.

I'm a bit over my head here, and a bit of help would be appreciated. Scripting below:

VBS that fires off program:

Option Explicit

RunFilePullMacro


Sub RunFilePullMacro() 


  Dim xlApp 
  Dim xlBook 
  Dim oShell
  
  Set oShell = CreateObject("Shell.Application")
  oShell.MinimizeAll
  
  Set xlApp = CreateObject("Excel.Application")
  'xlApp.Application.Visible = True
  xlApp.DisplayAlerts = False 
  Set xlBook = xlApp.Workbooks.Open("\\path to file\file.xlsm", 0, True) 
  xlApp.Run "FeedbackCheck"
  xlApp.ActiveWorkbook.Close
  xlApp.DisplayAlerts = True
  xlApp.Quit 


  Set xlBook = Nothing 
  Set xlApp = Nothing 
  Set oShell = Nothing


End Sub

Important bits of code from module (sorry if formatting is off, I'm just cropping out the relevant bits as the full code is a few hundred lines, and everything else is working as expected):

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _  (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
  ByVal lpParameters As String, ByVal lpDirectory As String, _
  ByVal nShowCmd As Long) As Long


Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Public Declare Function ShowWindow Lib "user32" _
  (ByVal hwnd As Long, ByVal nCmdSHow As Long) As Long
 
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  
Function apicShowWindow(strClassName As String, strWindowName As String, lngState As Long)
  
  'Declare variables
  Dim lngWnd As Long
  Dim intRet As Integer
  
  lngWnd = FindWindow(strClassName, strWindowName)
  apicShowWindow = ShowWindow(lngWnd, lngState)
End Function


Public Function fIsOutlookRunning() As Boolean


'Declare variables
Dim W As Object
Dim processes As Object
Dim process As Object


fIsOutlookRunning = False


Set W = GetObject("winmgmts:")
Set processes = W.execquery("SELECT * FROM win32_process")


For Each process In processes
  If process.Name = "OUTLOOK.EXE" Then
    fIsOutlookRunning = True
    Exit For
  End If
Next process


Set W = Nothing
Set processes = Nothing
Set process = Nothing


End Function


Public Sub OpenOutlook()


  If ShellExecute(Application.hwnd, vbNullString, "Outlook", vbNullString, "C:\", 1) < 33 Then
    MsgBox "Outlook not found."
  End If
  DoEvents


End Sub

Public Sub FeedbackCheck()


  'Set dims
  Dim msg As Outlook.MailItem
  Dim outl As Outlook.Application
  Dim strbody As String
  
  If fIsOutlookRunning = False Then Call OpenOutlook
  
  'Disable application layers
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False

'Create the mail
      Set outl = New Outlook.Application
      Set msg = outl.CreateItem(olMailItem)
                             
      On Error Resume Next
      With msg
        .To = CStr(cel.Offset(0, 1).Value)
        .Subject = "Weekly Report"
        .Body = strbody
        .Display
      End With
      DoEvents
      Sleep 1000
      
      'Set focus on message
      apicShowWindow vbNullString, "Weekly Report - Message (HTML) ", 9
    
      'Super hacky work-around to mail
      Sleep 1000
      outl.SendKeys "%s"
      DoEvents
      For i = 1 To 10
        Sleep 100
        outl.SendKeys "{TAB}"
      Next i
      DoEvents
      outl.SendKeys "~"
      DoEvents
      Sleep 1000
      outl.SendKeys "~"

      Set msg = Nothing
      Set outl = Nothing

  'Re-enable application layers
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True

End Sub