Visual Basic 5 Developer's Kit/vb5 dev kit.iso/dev/tbexit/frmright.frm

Visual Basic Form | 1996-01-12 | 7.3 KB | 221 lines

VERSION 4.00
Begin VB.Form frmRightClick
   Caption         =   "Form1"
   ClientHeight    =   3510
   ClientLeft      =   1140
   ClientTop       =   1515
   ClientWidth     =   5355
   Height          =   3915
   Icon            =   "frmRightClick.frx":0000
   Left            =   1080
   LinkTopic       =   "Form1"
   ScaleHeight     =   3510
   ScaleWidth      =   5355
   ShowInTaskbar   =   0   'False
   Top             =   1170
   Visible         =   0   'False
   Width           =   5475
   Begin MsghookLib.Msghook Msghook1
      Left            =   60
      Top             =   2940
      _version        =   65536
      _extentx        =   873
      _extenty        =   926
      _stockprops     =   0
   End
   Begin VB.Menu mnuShutDown
      Caption         =   "Shut Down"
      Visible         =   0   'False
      Begin VB.Menu mnuNormShutdown
         Caption         =   "Shut down the computer"
      End
      Begin VB.Menu mnuRebootSystem
         Caption         =   "Restart the computer"
      End
      Begin VB.Menu mnuRebootDos
         Caption         =   "Restart in MS-DOS mode"
      End
      Begin VB.Menu Sep1
         Caption         =   "-"
      End
      Begin VB.Menu mnuClose
         Caption         =   "Close WinExit"
      End
      Begin VB.Menu Sep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuCancel
         Caption         =   "Cancel"
      End
   End
Attribute VB_Name = "frmRightClick"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Private Type OsVersionInfo
    dwVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatform As Long
    szCSDVersion As String * 128
End Type
Private OsVer As OsVersionInfo
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2
Private Declare Function GetVersionEx& Lib "kernel32.dll" _
Alias "GetVersionExA" (lpStruct As OsVersionInfo)
'message constants for mouse events
Const WM_MOUSEMOVE = &H200
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const WM_LBUTTONDBLCLK = &H203
Const WM_RBUTTONDOWN = &H204
Const WM_RBUTTONUP = &H205
Const WM_RBUTTONDBLCLK = &H206
Const WM_MBUTTONDOWN = &H207
Const WM_MBUTTONUP = &H208
Const WM_MBUTTONDBLCLK = &H209
Dim TaskBar As New clsTaskBar
Const ICONID = 1
'Functions and constants for exiting Windows
Private Declare Function AbortSystemShutdown& Lib "advapi32.dll" _
Alias "AbortSystemShutdownA" (ByVal lpMachineName$)
Private Declare Function ExitWindowsEx& Lib "user32" _
(ByVal uFlags&, ByVal dwReserved&)
Const EWX_FORCE = 4
Const EWX_LOGOFF = 0
Const EWX_REBOOT = 2
Const EWX_SHUTDOWN = 1
'Functions for getting the Windows and Windows\System directories
Private Declare Function GetWindowsDirectory& Lib "kernel32" _
Alias "GetWindowsDirectoryA" (ByVal lpBuffer$, ByVal nSize&)
Private Declare Function GetSystemDirectory& Lib "kernel32" _
Alias "GetSystemDirectoryA" (ByVal lpBuffer$, ByVal nSize&)
Private sWinDir$ 'Windows directory
Private sSysDir$ 'Windows\System directory
Function StandardShutDown() As Long
StandardShutDown = ExitWindowsEx(EWX_SHUTDOWN, 0&)
End Function
Private Sub Form_Load()
Dim lTemp&
Dim iVersion%
Dim sTip$
Dim sBuffer$
Dim lBufferSize&
If App.PrevInstance Then End
'Determine the version of Windows that is running
OsVer.dwVersionInfoSize = 148&
lTemp = GetVersionEx(OsVer)
Select Case OsVer.dwPlatform
    Case VER_PLATFORM_WIN32_NT
        iVersion = (OsVer.dwMajorVersion * 100) + OsVer.dwMinorVersion
        If iVersion < 351 Then
            MsgBox "This program is not compatible with Windows NT 3.50 and earlier."
            Unload Me
            Exit Sub
        End If
    Case VER_PLATFORM_WIN32_WINDOWS
        'Running Windows 95 so no problem
    Case Else
        'Should only occur if Win32s is installed on Win 3.1, but the
        'program still won't work because there will be no task bar.
        MsgBox "This program can only run under Windows 95 or NT."
        Unload Me
End Select
'Check for presence of Taskbar.  The user may have a different
'shell that doesn't support one.
If TaskBar.TaskbarExists <> 1 Then
    MsgBox "There is no taskbar currently available"
    Unload Me
    Exit Sub
End If
'Enable the MsgHook control to receive messages from the taskbar
Msghook1.HwndHook = Me.hWnd
Msghook1.Message(TaskBar.CallbackMessage) = True
'Assign the forms' hwnd to the taskbar notify structure
TaskBar.hWnd = Me
'Now, add an icon to the system tray
TaskBar.AddIconToTray Me.Icon, ICONID
'Assign the tool tip for the icon
sTip = "Double Click to Exit Windows"
TaskBar.ChangeTip sTip, ICONID
'Get the Windows and Windows\System directories
sBuffer = Space(145)
lBufferSize = Len(sBuffer)
lTemp = GetWindowsDirectory(sBuffer, lBufferSize)
sWinDir = Left$(sBuffer, lTemp)
sBuffer = Space(145)
lTemp = GetSystemDirectory(sBuffer, lBufferSize)
sSysDir = Left$(sBuffer, lTemp)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Remove the icon from the task bar
TaskBar.DeleteIcon (ICONID)
'Disable subclassing
Msghook1.HwndHook = 0
End Sub
Private Sub mnuCancel_Click()
'Don't need to do anything here.  Just need a menu item
End Sub
Private Sub mnuClose_Click()
Unload Me
End Sub
Private Sub mnuNormShutdown_Click()
Dim lResult&
lResult = StandardShutDown
End Sub
Private Sub mnuRebootDos_Click()
Dim lResult&
Dim sPifFile$
'First, let's make sure the pif file exists
sPifFile = sWinDir & "\pif\exit to dos.pif"
If Not FileExists(sPifFile) Then
    'It's not where it's supposed to be, but let's check
    'in the Windows directory.
    sPifFile = sWinDir & "\exit to dos.pif"
    If Not FileExists(sPifFile) Then
        'Still can't find it.  One last check in the System directory
        sPifFile = sSysDir & "\exit to dos.pif"
        If Not FileExists(sPifFile) Then
            'Time to give up
            MsgBox "Can't find ""Exit To Dos.pif"".  Aborting Procedure", vbCritical
            Exit Sub
        End If
    End If
End If
lResult = Shell(sPifFile, 1)
End Sub
Function FileExists(filename$) As Boolean
'This sub checks for the existance of any filename passed to it
'Make sure that a filename was passed or the function
'will return TRUE since it will find any file that exists
'in the current directory.
If Len(filename) = 0 Then
    FileExists = False
    Exit Function
End If
If Len(Dir$(filename)) Then
    FileExists = True
    FileExists = False
End If
End Function
Private Sub mnuRebootSystem_Click()
Dim lResult&
lResult = ExitWindowsEx(EWX_REBOOT, 0&)
End Sub
Private Sub Msghook1_Message(ByVal msg As Long, ByVal wp As Long, ByVal lp As Long, result As Long)
'Only trapping one message so don't need to be concerned with the
'actual message.  The mouse event is contained in lParam, and
'the icon ID is contained in wParam.  Must use unique IDs for
'multiple icons.
Dim lResult&
Select Case lp
    'Left button double-click; normal Windows shutdown
    Case WM_LBUTTONDBLCLK
        lResult = StandardShutDown
    Case WM_RBUTTONUP
        PopupMenu mnuShutDown
End Select
End Sub