Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Prevent Excel From Closing

Excel How To

Prevent Excel From Closing

by  AccessGuruCarl  Posted    (Edited  )
This code will will prevent Excel from closing or give the user the option to close excel and log-off the computer.

Keywords: Prevent Excel from closing, Close Windows from Excel.

Paste this code into a new excel Module.
Code:
Option Explicit
'Set Types
Public Type LUID
   LowPart As Long
   HighPart As Long
End Type
Public Type LUID_AND_ATTRIBUTES
        pLuid As LUID
        Attributes As Long
End Type
Public Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    Privileges(1) As LUID_AND_ATTRIBUTES
End Type
' Declare API functions.
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, _
   ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" _
   (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, _
   ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength _
   As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

' Set Set ShutDown Privilege Constants
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const SE_PRIVILEGE_ENABLED = &H2

Public Sub SetShutDownPrivilege()
Dim Phndl As Long, Thndl As Long
Dim MyLUID As LUID
Dim MyPriv As TOKEN_PRIVILEGES, MyNewPriv As TOKEN_PRIVILEGES
Phndl = GetCurrentProcess()
OpenProcessToken Phndl, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, Thndl
LookupPrivilegeValue "", "SeShutdownPrivilege", MyLUID
MyPriv.PrivilegeCount = 1
MyPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
MyPriv.Privileges(0).pLuid = MyLUID
' Now to set shutdown privilege for my app
AdjustTokenPrivileges Thndl, False, MyPriv, 4 + (12 * MyPriv.PrivilegeCount), MyNewPriv, 4 + (12 * MyNewPriv.PrivilegeCount)
End Sub

Paste this code into the ThisWorkbook VBE
Code:
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Dim Msg, Style, Title, Response
Dim MyFlag As Long, Ret As String
'Set ShutDown Constants
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4

' Define message.
Msg = "Do you want to continue ?" _
    & vbCr & vbCr & "You are about to exit the Inventory program." _
    & vbCr & vbCr & "You will need to Reboot Computer" _
    & vbCr & "to restore the Inventory!"
Style = vbYesNoCancel + vbCritical + vbDefaultButton3    ' Define buttons.
Title = "Exiting Inventory"    ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
'Test the variable Response
Select Case Response
  Case vbYes
    'Save the file, Force Windows Closed
    Me.Save
 '   Call Exit_Windows
    Ret = InputBox("Enter Password", "Password Required")
        If Ret = "xyz" Then
        Ret = InputBox("Exit Excel or Logoff User" _
        & vbCr & " Enter: E or L", "What Action")
        Else
        MsgBox "Invalid Password", vbCritical, "Wrong Password"
        Cancel = False
        Exit Sub
        End If
    If Ret = "E" Or Ret = "e" Then
    'Do nothing -
    Else
    If Ret = "L" Or Ret = "l" Then
    SetShutDownPrivilege 'Set the shutdown privilege - else reboot will fail
' Always execute a force shutdown if a shutdown is required
    MyFlag = EWX_LOGOFF  'LogOff
' Grab the shutdown privilege - else reboot will fail
    SetShutDownPrivilege
' Do the required action
    Call ExitWindowsEx(MyFlag, 0)
    End If
    End If
  Case vbNo
    Worksheets(1).Activate
    Cancel = True
  Case vbCancel
    Cancel = True
  Case Else
  'Do Nothing
End Select

End Sub

Private Sub Workbook_Open()
On Error Resume Next
    'Activate the 1st worksheet using the workbooks worksheet index
    Worksheets(1).Activate
    'Or If you want to use the actual worksheet name
    'Worksheets("Sheet1").Activate
End Sub

That's it. Modify the close event as needed.
I'm currently logging the user off, so that an administrator can log on, via PC Anywhere and update the excel file.

Working like a charm....
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top