Option Explicit ' Always a Good Idea (TM)

' This is a DLL-centered class which exports as many of the kernel32.dll functions as I could either
' figure out (a very tiny number) or find in the MSKB, or find elsewhere on the Internet without
' restrictions on reproduction.  There were no significant portions of this one which came from a
' particular source beyond Microsoft.

' Constants - these are essentially all pulled
' straight from win32api.txt

Private Const ERROR_NO_MORE_FILES = 18&
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const MAX_PATH = 260
Private Const PROCESSOR_ALPHA_21064 = 21064
Private Const PROCESSOR_INTEL_386 = 386
Private Const PROCESSOR_INTEL_486 = 486
Private Const PROCESSOR_INTEL_PENTIUM = 586
Private Const PROCESSOR_MIPS_R4000 = 4000
Private Const READ_CONTROL = &H20000
Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const STD_OUTPUT_HANDLE = -11&
Private Const TOKEN_ADJUST_DEFAULT = (&H80)
Private Const TOKEN_ADJUST_GROUPS = (&H40)
Private Const TOKEN_ADJUST_PRIVILEGES = (&H20)
Private Const TOKEN_ASSIGN_PRIMARY = &H1
Private Const TOKEN_DUPLICATE = (&H2)
Private Const TOKEN_EXECUTE = (STANDARD_RIGHTS_EXECUTE)
Private Const TOKEN_IMPERSONATE = (&H4)
Private Const TOKEN_QUERY = (&H8)
Private Const TOKEN_QUERY_SOURCE = (&H10)
Private Const TokenDefaultDacl = 6
Private Const TokenGroups = 2
Private Const TokenImpersonationLevel = 9
Private Const TokenOwner = 4
Private Const TokenPrimaryGroup = 5
Private Const TokenPrivileges = 3
Private Const TokenSource = 7
Private Const TokenStatistics = 10
Private Const TokenType = 8
Private Const TokenUser = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const TOKEN_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or TOKEN_ASSIGN_PRIMARY Or TOKEN_DUPLICATE Or TOKEN_IMPERSONATE Or TOKEN_QUERY Or TOKEN_QUERY_SOURCE Or TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)
Private Const TOKEN_READ = (STANDARD_RIGHTS_READ Or TOKEN_QUERY)
Private Const TOKEN_WRITE = (STANDARD_RIGHTS_WRITE Or TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)

' "Special" Types of variables (again mostly Microsoft in origin)
Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformID As Long
  szCSDVersion As String * 128
End Type
Private Type LARGE_INTEGER
  LowPart As Long
  HighPart As Long
End Type
Private Type LUID
  LowPart As Long
  HighPart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
  pLuid As LUID
  Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
  PrivilegeCount As Long
  Privileges(0 To 0) As LUID_AND_ATTRIBUTES
End Type

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type
Private Type SYSTEM_INFO
  dwOemID As Long
  dwPageSize As Long
  lpMinimumApplicationAddress As Long
  lpMaximumApplicationAddress As Long
  dwActiveProcessorMask As Long
  dwNumberOrfProcessors As Long
  dwProcessorType As Long
  dwAllocationGranularity As Long
  dwReserved As Long
End Type
Private Type MEMORYSTATUS
  dwLength As Long
  dwMemoryLoad As Long
  dwTotalPhys As Long
  dwAvailPhys As Long
  dwTotalPageFile As Long
  dwAvailPageFile As Long
  dwTotalVirtual As Long
  dwAvailVirtual As Long
End Type


'These are declarations that make it possible for us to call various Kernel32.DLL APIs
Private Declare Function AbortSystemShutdownA Lib "advapi32.dll" (ByVal lpMachineName As String) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (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
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CopyFileA Lib "kernel32" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFileA Lib "kernel32" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFileA Lib "kernel32" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetACP Lib "kernel32" () As Long
Private Declare Function GetConsoleCP Lib "kernel32" () As Long
Private Declare Function GetConsoleOutputCP Lib "kernel32" () As Long
Private Declare Function GetConsoleTitleA Lib "kernel32" (ByVal lpConsoleTitle As String, ByVal nSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetEnvironmentStringsA Lib "kernel32" () As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetOEMCP Lib "kernel32" () As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function GetSystemDefaultLangID Lib "kernel32" () As Integer
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Private Declare Function GetTempFileNameA Lib "kernel32" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPathA Lib "kernel32" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetThreadLocale Lib "kernel32" () As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" (ByVal TokenHandle As Long, TokenInformationClass As Integer, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long
Private Declare Function GetUserDefaultLangID Lib "kernel32" () As Integer
Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetVolumeInformationA Lib "kernel32" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function InitiateSystemShutdownA Lib "advapi32.dll" (ByVal lpMachineName As String, ByVal lpMessage As String, ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function IsDebuggerPresent Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValueA Lib "advapi32.dll" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function MoveFileA Lib "kernel32" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function ReadConsoleA Lib "kernel32" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Private Declare Function SetConsoleTitleA Lib "kernel32" (ByVal lpConsoleTitle As String) As Long
Private Declare Function TlsAlloc Lib "kernel32" () As Long
Private Declare Function WriteConsoleA Lib "kernel32" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Dim hConsole As Long
Public Property Get EnvironmentStrings() As String
Dim lngRet As Long
Dim strDest As String
lngRet = GetEnvironmentStringsA
'32768 is a "Magic" number - just used it to make sure this would never overflow
strDest = String$(32768, " ")
RtlMoveMemory ByVal strDest, ByVal lngRet, Len(strDest) - 1
EnvironmentStrings = strDest
End Property
Public Property Get FileSystemType(ByVal Drive As String) As String
  Dim sVolBuf As String * 255
  Dim sSysName As String * 255
  Dim lSerialNum As Long
  Dim lSysFlags As Long
  Dim lComponentLength As Long
  Dim lRes As Long
  lRes = GetVolumeInformationA(Drive, sVolBuf, 255, lSerialNum, lComponentLength, lSysFlags, sSysName, 255)
  If lRes Then
    FileSystemType = Left$(sSysName, InStr(sSysName, Chr$(0)) - 1)
  Else
    FileSystemType = "other"
  End If
End Property
Public Property Get Uptime() As Long
  Uptime = GetTickCount
End Property
Public Function SystemCPU() As Long
  Dim sysinfo As SYSTEM_INFO
  GetSystemInfo sysinfo
  SystemCPU = sysinfo.dwProcessorType
End Function

'MEMORY FUNCTIONS
Public Property Get TotalPhysicalMemory() As Long
  Dim memsts As MEMORYSTATUS
  GlobalMemoryStatus memsts
  TotalPhysicalMemory = memsts.dwTotalPhys
End Property
Public Property Get AvailablePhysicalMemory() As Long
  Dim memsts As MEMORYSTATUS
  GlobalMemoryStatus memsts
  AvailablePhysicalMemory = memsts.dwAvailPhys
End Property
Public Property Get TotalVirtualMemory() As Long
  Dim memsts As MEMORYSTATUS
  GlobalMemoryStatus memsts
  TotalVirtualMemory = memsts.dwTotalVirtual
End Property
Public Property Get AvailableVirtualMemory() As Long
  Dim memsts As MEMORYSTATUS
  GlobalMemoryStatus memsts
  AvailableVirtualMemory = memsts.dwAvailVirtual
End Property
' END MEMORY FUNCTIONS ---------
Function FileCopy(Source As String, Target As String) As Boolean
  FileCopy = CopyFileA(Trim$(Source), Trim(Target), False)
End Function
Function FileMove(Source As String, Target As String) As Boolean
  FileMove = MoveFileA(Trim$(Source), Trim(Target))
End Function
Public Property Get LastKernelError() As Long
  LastKernelError = GetLastError
End Property
Public Property Get OEMCodePage() As Long
  OEMCodePage = GetOEMCP
End Property
Public Property Get SystemLanguage() As Long
  SystemLanguage = GetSystemDefaultLangID
End Property
Public Property Get ACP() As Long
  ACP = GetACP
End Property
Public Property Get UserLanguage() As Long
  UserLanguage = GetUserDefaultLangID
End Property
Public Property Get SystemLCID() As Long
  SystemLCID = GetSystemDefaultLCID
End Property
Public Property Get UserLCID() As Long
  UserLCID = GetUserDefaultLCID
End Property
Public Property Get Process() As Long
  Process = GetCurrentProcess
End Property
Public Property Get ProcessID() As Long
  ProcessID = GetCurrentProcessId
End Property
Public Property Get Thread() As Long
  Thread = GetCurrentThread
End Property
Public Property Get ThreadID() As Long
  ThreadID = GetCurrentThreadId
End Property
Public Property Get Heap() As Long
  Heap = GetProcessHeap
End Property
Public Property Get Version() As Long
  Version = GetVersion
End Property
Public Property Get ConsoleCodePage() As Long
  ConsoleCodePage = GetConsoleCP
End Property
Public Property Get ConsoleOutputCodePage() As Long
  ConsoleOutputCodePage = GetConsoleOutputCP
End Property
Public Property Get LogicalDrives() As Long
  LogicalDrives = GetLogicalDrives
End Property
Public Property Get IsInDebugger() As Boolean
  IsInDebugger = IsDebuggerPresent
End Property
Public Function ConsoleWrite(sToConsole As String)
  Dim cWritten As Long
  ConsoleWrite = WriteConsoleA(hConsole, ByVal sToConsole, Len(sToConsole), cWritten, ByVal 0&)
End Function
Public Function OpenConsole() As Long
  OpenConsole = False
  If AllocConsole() Then
    hConsole = GetStdHandle(STD_OUTPUT_HANDLE)
    OpenConsole = True
  End If
End Function
Public Sub ConsoleClose(hConsole)
  CloseHandle hConsole
  FreeConsole
End Sub
Public Sub MakeMeService()
  Dim pid As Long
  Dim regserv As Long
  pid = GetCurrentProcessId()
  regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub
Public Sub UnMakeMeService()
  Dim pid As Long
  Dim regserv As Long
  pid = GetCurrentProcessId()
  regserv = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)
End Sub
Public Function GetTempFilename(Optional Prefix As String = "") As String
Dim lngReturnVal As Long
Dim strTempPath As String * 255
Dim strTempFilename As String * 255
lngReturnVal = GetTempPathA(254, strTempPath)
lngReturnVal = GetTempFileNameA(strTempPath & "\", Prefix, 0, strTempFilename)
GetTempFilename = strTempFilename
End Function
Public Property Get IsNT() As Boolean
  Static bOnce As Boolean
  Static bValue As Boolean
  ' Return whether the system is running NT or not:
  If Not (bOnce) Then
    Dim tVI As OSVERSIONINFO
    tVI.dwOSVersionInfoSize = Len(tVI)
    If (GetVersionExA(tVI) <> 0) Then
      bValue = (tVI.dwPlatformID = VER_PLATFORM_WIN32_NT)
      bOnce = True
    End If
  End If
  IsNT = bValue
End Property
Public Function NTForceTimedShutdown(Optional ByVal lTimeOut As Long = -1, Optional ByVal sMsg As String = "", Optional ByVal sMachineNetworkName As String = vbNullString, Optional ByVal bForceAppsToClose As Boolean = False, Optional ByVal bReboot As Boolean = False) As Boolean
  Dim lR As Long
  If IsNT Then
    ' Make sure we have enabled the privilege to shutdown
    ' for this process if we're running NT:
    If Not (NTEnableShutDown(sMsg)) Then
      Exit Function
    End If
    ' This is the code to do a timed shutdown:
    lR = InitiateSystemShutdownA(sMachineNetworkName, sMsg, lTimeOut, bForceAppsToClose, bReboot)
    If (lR = 0) Then
      Err.Raise 513, "Call to InitiateSystemShutdownA failed."
    End If
  Else
    Err.Raise 514, "Function only available under Windows NT."
  End If
End Function
Public Function NTAbortTimedShutdown(Optional ByVal sMachineNetworkName As String = vbNullString)
  AbortSystemShutdownA sMachineNetworkName
End Function
Private Function NTEnableShutDown(ByRef sMsg As String) As Boolean
  Dim tLUID As LUID
  Dim hProcess As Long
  Dim hToken As Long
  Dim tTP As TOKEN_PRIVILEGES, tTPOld As TOKEN_PRIVILEGES
  Dim lTpOld As Long
  Dim lR As Long
  ' Next steps are all to enable the SE_SHUTDOWN_NAME privilege in our process so the system
  ' doesn't say "Who the hell are YOU?"
  ' First get the Shutdown LUID (I don't really understand this part)
  lR = LookupPrivilegeValueA(vbNullString, SE_SHUTDOWN_NAME, tLUID)
  If (lR <> 0) Then
      ' If we get it, the we find the current process handle:
    hProcess = GetCurrentProcess()
    If (hProcess <> 0) Then
      ' Open the token for adjusting and querying (if
      ' we can - user may not have rights):
      lR = OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken)
      If (lR <> 0) Then
        ' Ok we can now adjust the
        ' shutdown priviledges:
        With tTP
          .PrivilegeCount = 1
          With .Privileges(0)
            .Attributes = SE_PRIVILEGE_ENABLED
            .pLuid.HighPart = tLUID.HighPart
            .pLuid.LowPart = tLUID.LowPart
          End With
        End With
        ' Now allow this process to shutdown the system:
        lR = AdjustTokenPrivileges(hToken, 0, tTP, Len(tTP), tTPOld, lTpOld)
        If (lR <> 0) Then
          NTEnableShutDown = True
        Else
          Err.Raise 515, "You do not have shutdown privileges (AdjustTokenPrivileges Failed)."
        End If
        ' Close the handle - won't matter much if we're going down:
        CloseHandle hToken
      Else
        Err.Raise 516, "You do not have shutdown privileges (OpenProcessToken Failed)."
      End If
    Else
      Err.Raise 517, "Can't determine handle of our process - cannot shut down."
    End If
  Else
    Err.Raise 518, "Can't find SE_SHUTDOWN_NAME."
  End If
End Function