WScript.Shell PopUp not working

[QuantumSquirrel]

Hi all,

I have a workbook which is a shared server file that i have set to close after 20 minutes of inactivity to keep it available to all users if someone goes on holiday for a week and leaves it open on their machine. It warns them with a splash UserForm when it opens. It also creates a folder if needed & saves a copy before closing & deletes old copies to conserve disk space.
It works fine but my boss decided that it would be nice to include a pop up warning that it was about to close. I thought the "CreateObject("WScript.Shell").PopUp" method was just what i wanted but it seems really flaky. The code in the If statement for the response from the ok button always seems to work but the code for the response when the message box is ignored sometimes works ok when no other excel workbooks are open but only intermittently works if other workbooks are open.

Also the popup wont appear over other applications which i need it to do. Any ideas please anyone?

i have the following code in the "thisworkbook" object:-

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    ActiveWindow.Visible = False
    SplashUserForm.Show
    Windows(ThisWorkbook.Name).Visible = True
    Application.ScreenUpdating = True
    
    'deletes backup files older than 7 days
    Call DeleteOldFiles
    
    Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopTimer
End Sub
Private Sub Workbook_SheetCalculate(ByVal SH As Object)
    Call StopTimer
    Call SetTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal SH As Object, _
  ByVal Target As Excel.Range)
    Call StopTimer
    Call SetTimer
End Sub

Sub DeleteOldFiles()
    
    'Clear out all files over 7 days old from Dir_Path folder.
    Dir_Path = "C:\Users\Public\Manufacturing Plan Backups"
    'Set the number of days
    iMaxAge = 7
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    'Check that the folder exists
    If oFSO.FolderExists(Dir_Path) Then
        For Each oFile In oFSO.GetFolder(Dir_Path).Files
            'Looks at each file to check if it is older than 7 days and deletes older files
            If DateDiff("d", oFile.DateLastModified, Now) > iMaxAge Then
                oFile.Delete
            End If
        Next
    End If

    End Sub

i have the following code in "module1" :-

Option Explicit

Dim DownTime As Date
Dim Result As Integer
Sub SetTimer()
    'set the time duration the file can remain unattended for before close event
    DownTime = Now + TimeValue("00:30:00")
    Application.OnTime EarliestTime:=DownTime, _
      Procedure:="ShutDown", Schedule:=True
End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=DownTime, _
      Procedure:="ShutDown", Schedule:=False
 End Sub
Sub ShutDown()

Const PopupDurationSecs As Integer = 5

Application.DisplayAlerts = False

'activate & maximise
ThisWorkbook.Activate
ActiveWindow.WindowState = xlMaximized

' Call the Popup method with a 5 second timeout.
Result = CreateObject("WScript.Shell").PopUp( _
"This file is about to close. Click OK to keep it open", PopupDurationSecs, _
"Manufacturing Plan", 0 + 48)

If Result = 1 Then 'will stay open
    Call StopTimer
    Call SetTimer
    
ElseIf Result = -1 Then 'will close
'runs the subroutine to save a copy of the file before closing
Call SaveCopy
'Closes the file & ensures that an empty Excel shell does not remain on screen
If Application.Workbooks.Count > 1 Then
   ThisWorkbook.Saved = True
   ThisWorkbook.Close
Else
    Application.Quit
End If

    
End If

End Sub
Sub SaveCopy()

'saves a copy of the file to the required folder - creates the folder if it does not yet exist
'makes this workbook the active workbook and makes it the front window on the desktop
'to avoid the wrong excel file being saved if more than one excel files are open.

Dim dirstr As String, DateTime As String, SavePath As String
Dim wb As Workbook

'activate & maximise
ThisWorkbook.Activate
ActiveWindow.WindowState = xlMaximized
Set wb = ActiveWorkbook

'save a copy
dirstr = "C:\Users\Public\Manufacturing Plan Backups"
DateTime = Format(CStr(Now), "dd-mm-yyyy" & " " & "hh-mm-ss")
SavePath = dirstr & "\Copy Of Manufacturing Plan" & " " & DateTime

If Not DirectoryExist(dirstr) Then
MkDir dirstr
wb.SaveAs Filename:=SavePath & ".XLSX", FileFormat:=51
Else
wb.SaveAs Filename:=SavePath & ".XLSX", FileFormat:=51
End If
End Sub

Function DirectoryExist(sstr As String) 'checks if the save to folder exists
Dim lngAttr As Long
DirectoryExist = False
If Dir(sstr, vbDirectory) <> "" Then
lngAttr = GetAttr(sstr)
If lngAttr And vbDirectory Then _
DirectoryExist = True
End If
End Function

i have the following code in "module2" :-

Option Explicit
' functions used by the HideBar subroutine below
#If VBA7 Then
    Public Declare PtrSafe Function FindWindow Lib "user32" _
                Alias "FindWindowA" _
               (ByVal lpClassName As String, _
                ByVal lpWindowName As String) As Long


    Public Declare PtrSafe Function GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long) As Long


    Public Declare PtrSafe Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long


    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
               (ByVal hWnd As Long) As Long
#Else
    Public Declare Function FindWindow Lib "user32" _
                Alias "FindWindowA" _
               (ByVal lpClassName As String, _
                ByVal lpWindowName As String) As Long


    Public Declare Function GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long) As Long


    Public Declare Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long


    Public Declare Function DrawMenuBar Lib "user32" _
               (ByVal hWnd As Long) As Long
#End If


Sub HideBar(frm As Object)
'code to hide the title bar on the splash screen
Dim Style As Long, Menu As Long, hWndForm As Long
hWndForm = FindWindow("ThunderDFrame", frm.Caption)
Style = GetWindowLong(hWndForm, &HFFF0)
Style = Style And Not &HC00000
SetWindowLong hWndForm, &HFFF0, Style
DrawMenuBar hWndForm

End Sub

i have the following code in the "SplashUserForm" UserForm:-

Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub

Private Sub UserForm_Activate()
    Application.Wait (Now + TimeValue("00:00:01"))
    SplashUserForm.Label1.Caption = "Loading Data..."
    SplashUserForm.Repaint
    Application.Wait (Now + TimeValue("00:00:01"))
    SplashUserForm.Label1.Caption = "Creating Forms..."
    SplashUserForm.Repaint
    Application.Wait (Now + TimeValue("00:00:01"))
    SplashUserForm.Label1.Caption = "Opening..."
    SplashUserForm.Repaint
    Application.Wait (Now + TimeValue("00:00:01"))
    Unload SplashUserForm
End Sub

Private Sub UserForm_Initialize()

'Remove Border and Title Bar
HideBar Me

End Sub

 

[Anthony47]

When I wish to show a popup on the screen I use this code:

    GloMess = "A message from the boss"
    Rispo = Shell("mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(""" & GloMess & """,7,""Information:"",64))")

This shows a popup with the specified text message; the popup can be closed, or will disappear after 7 seconds (7 is set in the code). It works "most of the times"

Bye
PS: don't ask me to explain the code, I copied it somewhere several years ago.

 

[QuantumSquirrel]

When I wish to show a popup on the screen I use this code:

    GloMess = "A message from the boss"
    Rispo = Shell("mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(""" & GloMess & """,7,""Information:"",64))")

This shows a popup with the specified text message; the popup can be closed, or will disappear after 7 seconds (7 is set in the code). It works "most of the times"

Bye
PS: don't ask me to explain the code, I copied it somewhere several years ago.

Thanks for your response Anthony.
If I define Rispo as integer & GloMess as string it works in so far as it pops a box up that you can close or it closes itself after a few seconds, but that seems to be all it will do. I cant see a way to change the actions the code will perform depending on whether the ok button is clicked or ignored. I need to be able to set this with this code.
Anybody have any ideas please?

 

[Anthony47]

What I gave is a code able to show a popup on top of the current window, and inform about an action in progress; there is not any interaction (except closing the message earlier than its programmed time out), and the macro contines just after the popup is rised (without waiting the programmed time out).
I didn't realize you need an interactive popup, sorry...

Maybe (maybe) you could benefit from the windows messagebox; search with thi string:

vba using "MsgBoxW"

Bye