troubleshooting Question

How to detect system shutdown with a form-less Visual Basic application

Avatar of EasyAim
EasyAim asked on
Visual Basic Classic
11 Comments1 Solution5811 ViewsLast Modified:
I made the mistake of accepting an answer from a previous posted question without checking it out thoroughly.  It was:

https://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_20869890.html

As it turns out, the answer did not work, so I'm repeating the question. (I do stupid things like that when I don't have time to check out an answer but I'm getting pinged to close a question):

   I have a Visual Basic application that has no form.   It uses the API function 'Sleep()' to wake up every so often to check for downloaded files and other maintenance issues.  The problem is during a system reboot a very unprofessional shutdown error dialog box appears:

   "Ending program.... please wait"   with a progress bar.  

It eventually throws an error that requires human intervention to completely shut down.  (I'm not sure about other operating systems but this does occur for Windows 2000 anyway.)

REQUEST #1:  Can the 'ending program' dialog box be programmatically disabled to allow shutdown to continue?

REQUEST #2:  If not, how can I programmatically detect an operating system shut down?

NOTE:  Answers that use the Form_QueryUnload or anything else associated with a Visual Basic form will be rejected.  This application has no VB form.   A VB form will not be put into this application.

One method I thought that would work would be to detect registry changes.  I would have assumed that when a shutdown is initiated that some registry entry is changed... but I can't find it.  It may be the wrong method anyway.    Below is a test routine that checks various registry changes during a system shut down.  All of the registry entries noted in the code below had no change detected during a shutdown.

The utility below is one form with one button.  It creates a log file in the root directory called "c:\trash.log".  Note: this is a routine to check for registry changes during a shutdown.  It is NOT the routine that is causing the pop-up shutdown error.

'===============================================================
' "DetectShutDown"
' Attempt to detect a shutdown event without using a Form event
'
' INSTRUCTIONS:
'   * Create a Visual Basic form with one large button.
'     Name the button 'cmdStart'.
'   * Copy this code to the form.
'   * Create an executable of this code.
'   * Run the executable.
'   * Allow a few seconds to go by to get a baseline reading of
'     all of the registry values.
'   * Shutdown your computer using 'Start' / 'Turn off computer' / 'Restart'
'   * Upon re-starting the computer, review the log file "c:\trash.log"
'     and determine if any of the registry values indicated a shutdown.
'---------------------------------------------------------------
Option Explicit
'
Dim sFileLog As String
'
Const WAIT_TIME As Single = 0.5  ' wait number of seconds between cycles
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   dwType As Long, ByVal lpValue As String, cbData As Long) As Long
'
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
  (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
'
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'
Private Declare Function RegQueryValueExNull Lib "advapi32.dll" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
'
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
   lpType As Long, lpData As Long, lpcbData As Long) As Long
'
Const HKEY_CLASSES_ROOT As Long = &H80000000
Const HKEY_CURRENT_USER As Long = &H80000001
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Const HKEY_USERS As Long = &H80000003
Const KEY_ALL_ACCESS = &H3F
Const ERROR_NONE = 0
Const REG_SZ As Long = 1
Const REG_DWORD As Long = 4

'
'==========================================================
Private Sub Form_Load()
   sFileLog = "c:\trash.log"
End Sub

'
'==========================================================
Private Sub cmdStart_Click()
 Dim i As Long
 Dim h As Integer
 Dim sTemp As String
 Dim iCount As Long
 Dim sngWakeUp As Single
 '
 cmdStart.Caption = "RUNNING!" & vbCrLf & "see file: " & sFileLog
 '
  h = FreeFile
  Open sFileLog For Output As h
  Print #h, String$(60, "=")
  Print #h, " file: " & sFileLog
  Print #h, " created: " & Format$(Now, "mm/dd/yyyy hh:nn:ss")
  Print #h, " "
  Print #h, "NOTE: Not all registry entries will be found, depending upon your operating system."
  Print #h, String$(60, "-")
  Close h
 '
 Do
   iCount = iCount + 1
   Me.Caption = "Loop number " & iCount
   '
   ' The API Sleep() function causes the warning to appear.
   Call Sleep(WAIT_TIME * 1000)
   '
   ' attempt to detect system shutdown
   '
   ' Note: Not all operating systems have these registry entries.
   '
   Logger " "
   Logger "**** LOOP " & CStr(iCount) & " *****"
   sTemp = GetKeyValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer", "CleanShutdown", "-1")
     Logger "Explorer:CleanShutDown =              " & sTemp
     '
   sTemp = GetKeyValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer", "Shutdown Setting", "-1")
     Logger "Explorer:Shutdown Setting =           " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\policies\system", "Shutdownwithoutlogon", "-1")
     Logger "policies:Shutdownwithoutlogon =       " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify\cscdll", "Shutdown", "-1")
     Logger "Winlogon:cscdll =                     " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Reliability", "ShutdownDoStateSnapshot", "-1")
     Logger "Reliability:ShutdownDoStateSnapshot = " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Reliability", "ShutdownReasonUI", "-1")
     Logger "Reliability:ShutdownReasonUI =        " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Watchdog\Display", "Shutdown", "-1")
     Logger "Watchdog:Shutdown =                   " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Watchdog\Display", "ShutdownCount", "-1")
     Logger "Watchdog:ShutdownCount =              " & sTemp
     '
   sTemp = GetKeyValue(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\Windows", "ShutdownTime", "-1")
     Logger "CurrentControlSet:ShutdownTime =      " & sTemp
     '
   Me.Refresh
   '
 Loop

End Sub
'
'=============================================================
Private Function GetKeyValue(lParentKey As Long, sKeyName As String, sParam As String, Optional sDefault As String = vbNullString) As String
 '
 ' Read a registry entry.
 '
 ' INPUT:
 '   lParentKey = see the above declarations for the root id number
 '   sKeyName = the fully nested key name
 '   sParam   = the parameter where the value is stored
 '   sDefault = the default value if no key exists
 ' OUTPUT:
 '   ReadKey  = the stored value
 '
 Dim lResult As Long
 Dim hKey As Long       ' handle to opened key
 Dim vValue As Variant  ' returned value
 lResult = RegOpenKeyEx(lParentKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
 lResult = QueryValueEx(hKey, sParam, vValue)
 If lResult <> ERROR_NONE Then vValue = sDefault
 GetKeyValue = TrimToNull(CStr(vValue))
 If Len(GetKeyValue) < 1 Then GetKeyValue = sDefault
 RegCloseKey (hKey)
End Function

'
'================================================================
Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
  '
  Dim cCh As Long
  Dim lRc As Long
  Dim lType As Long
  Dim lValue As Long
  Dim sValue As String
  '
  ' Determine the size and type of data to be read
  lRc = RegQueryValueExNull(lhKey, szValueName, 0&, lType, 0&, cCh)
  If lRc <> ERROR_NONE Then
    vValue = "(registry entry does not exist)"
    Exit Function
  End If
  '
  Select Case lType
    ' strings
    Case REG_SZ
      sValue = String(cCh, 0)
      lRc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cCh)
      If lRc = ERROR_NONE Then
        vValue = Left$(sValue, cCh)
      Else
        vValue = Empty
      End If
    '
    ' for DWORDS
    Case REG_DWORD
      lRc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cCh)
      If lRc = ERROR_NONE Then vValue = lValue
    Case Else
      lRc = -1
    End Select
    QueryValueEx = lRc
    End Function

'
'=================================================================
Private Sub Logger(strInput As String)
 '
 '  Write to a log file
 '-----------------------------------------------------------------------------
 Dim hLog As Integer
 Dim strEntry As String
 '
 strEntry = Format$(Now, "mm/dd/yyyy hh:mm:ss") & "  " & strInput
 '
 If Len(sFileLog) > 0 Then
   hLog = FreeFile
   Open sFileLog For Append As hLog
   Print #hLog, strEntry
   Close hLog
 End If
 End Sub

'
'=================================================================
Private Function TrimToNull(strInput As String) As String
  Dim i As Long
  i = InStr(1, strInput, Chr$(0), vbBinaryCompare)
  Select Case i
  Case 0
    TrimToNull = strInput
  Case 1
    TrimToNull = vbNullString
  Case Else
    TrimToNull = Left$(strInput, i - 1)
  End Select
End Function


Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 1 Answer and 11 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 11 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros