Attribute VB_Name = "CpuLoad"
Option Explicit

Public xProcList() As MYPROCESSENTRY32
Public NewProcList() As MYPROCESSENTRY32
Public LastProcList() As MYPROCESSENTRY32

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long



Public LastProcCnt As Long

Public NewProcCnt As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long


Dim FirstTime As Boolean

Public Enum SHOWCMDFLAGS
    SHOWNORMAL = 5
    SHOWMAXIMIZE = 3
    ShowMinimize = 7
End Enum

Public Enum FILEOPTION
    SW_HIDE = 0
    SW_SHOWNORMAL = 1
    SW_SHOWMINIMIZED = 2
    SW_SHOWMAXIMIZED = 3
    SW_MAXIMIZE = 3
    SW_SHOWNOACTIVATE = 4
    SW_SHOW = 5
    SW_MINIMIZE = 6
    SW_SHOWMINNOACTIVE = 7
    SW_SHOWNA = 8
    SW_RESTORE = 9
    SW_SHOWDEFAULT = 10
End Enum

Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Const SYSTEM_BASICINFORMATION = 0&
Private Const SYSTEM_PERFORMANCEINFORMATION = 2&
Private Const SYSTEM_TIMEINFORMATION = 3&
Private Const BYTETOMB = &H100000
Private Const S_OK = 0

Const SPI_GETWORKAREA = 48
Private Const SPI_SETWORKAREA = 47


Private Const MAX_PATH = 260
Private Const SHGFP_TYPE_CURRENT = &H0
Private Const CSIDL_FLAG_CREATE = &H8000&

Private Const OSVERSIONINFOSIZE = 148
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_NT_WORKSTATION = 1
Private Const VER_SUITE_PERSONAL As Long = &H200
Private Const VER_NT_SERVER = 3
Private Const VER_SUITE_DATACENTER As Long = &H80
Private Const VER_SUITE_ENTERPRISE As Long = &H2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0

Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16

Public Const TH32CS_SNAPPROCESS = &H2&
Public Const TH32CS_SNAPMODULE = &H8&
Private Const MAX_MODULE_NAME32 As Integer = 255
Private Const MAX_MODULE_NAME32plus As Integer = MAX_MODULE_NAME32 + 1


'Folders
Public Enum SpecialFolders
    CSIDL_DESKTOP = &H0&            ' \Desktop
    CSIDL_PROGRAMS = &H2&           ' \Start Menu\Programs
    CSIDL_CONTROLS = &H3&           ' No Path
    CSIDL_PRINTERS = &H4&           ' No Path
    CSIDL_FAVORITES = &H6&          ' \Favorites
    CSIDL_STARTUP = &H7&            ' \Start Menu\Programs\Startup
    CSIDL_RECENT = &H8&             ' \Recent
    CSIDL_SENDTO = &H9&             ' \SendTo
    CSIDL_STARTMENU = &HB&          ' \Start Menu
    CSIDL_DESKTOPDIRECTORY = &H10&  ' \Desktop
    CSIDL_NETHOOD = &H13&           ' \NetHood
    CSIDL_FONTS = &H14&             ' \fonts
    CSIDL_TEMPLATES = &H15&         ' \ShellNew
    CSIDL_COMMON_STARTMENU = &H16&  ' ..\WinNT\profiles\All Users\Start Menu
    CSIDL_COMMON_PROGRAMS = &H17&   ' ..\WinNT\profiles\All Users\Start Menu\Programs
    CSIDL_COMMON_STARTUP = &H18&    ' ..\WinNT\profiles\All Users\Start Menu\Programs\Startup
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19& '..\WinNT\profiles\All Users\Desktop
    CSIDL_PRINTHOOD = &H1B&         ' ..\WinNT\profiles\username\PrintHood
    CSIDL_APPDATA = &H1A                '{user}\Application Data
    CSIDL_COMMON_APPDATA = &H23         '(all users)\Application Data
    CSIDL_COMMON_DOCUMENTS = &H2E       '(all users)\Documents
    CSIDL_COOKIES = &H21
    CSIDL_HISTORY = &H22
    CSIDL_INTERNET_CACHE = &H20         'Internet Cache folder
    CSIDL_LOCAL_APPDATA = &H1C          '{user}\Local Settings\Application Data (non roaming)
    CSIDL_MYPICTURES = &H27             'C:\Program Files\My Pictures
    CSIDL_PERSONAL = &H5                'My Documents
    CSIDL_PROGRAM_FILES = &H26          'Program Files folder
    CSIDL_PROGRAM_FILES_COMMON = &H2B  'Program Files\Common
    CSIDL_SYSTEM = &H25                 'system folder
    CSIDL_WINDOWS = &H24                'Windows directory or SYSROOT()
End Enum

Private Type LARGE_INTEGER
    dwLow   As Long
    dwHigh  As Long
End Type

Private Type SYSTEM_BASIC_INFORMATION
    dwUnknown1                  As Long
    uKeMaximumIncrement         As Long
    uPageSize                   As Long
    uHmNumberOfPhysicalPages    As Long
    uHmLowestOfPhysicalPages    As Long
    uHmHighestOfPhysicalPages   As Long
    uAllocationGranularity      As Long
    pLowestUserAdress           As Long
    pHighetsUserAdress          As Long
    uKeActiveProcessors         As Long
    bKeNumberProcessors         As Byte
    bUnknown2                   As Byte
    wUnknown3                   As Integer
End Type

Private Type SYSTEM_PERFORMANCE_INFORMATION
    LiIdleTime          As LARGE_INTEGER
    dwsSpace(0 To 75)    As Long
End Type

Private Type SYSTEM_TIME_INFORMATION
    LiKeBootime         As LARGE_INTEGER
    LiKeSystemTime      As LARGE_INTEGER
    LiExpTimeZoneBias   As LARGE_INTEGER
    uCurrentTimeZoneId  As Long
    dwReserved          As Long
End Type

Public 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

Private Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128
    wServicePackMajor   As Integer
    wServicePackMinor   As Integer
    wSuiteMask          As Integer
    bProductType        As Byte
    bReserved           As Byte
End Type

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Private Type PALETTEENTRY
    peRed   As Byte
    peGreen As Byte
    peBlue  As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion       As Integer
    palNumEntries    As Integer
    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors
End Type

Private Type GUID
    Data1    As Long
    Data2    As Integer
    Data3    As Integer
    Data4(7) As Byte
End Type

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Public Type PROCESSOR_INFORMATION
    CPUName As String
    CPUCaption As String
    CPUStatus As String
    CPUCurrentClockSpeed As Long
    CPUExtClock As Long
    CPULevel As Long
    CPUManufacturer As String
    CPUMaxClockSpeed As Long
End Type

Public Type PROCESSENTRY32
   dwSize               As Long 'Specifies the length, in bytes, of the structure.
   cntUsage             As Long 'Number of references to the process.
   th32ProcessID        As Long 'Identifier of the process.
   th32DefaultHeapID    As Long 'Identifier of the default heap for the process.
   th32ModuleID         As Long 'Module identifier of the process. (Associated exe)
   cntThreads           As Long 'Number of execution threads started by the process.
   th32ParentProcessID  As Long 'Identifier of the process that created the process being examined.
   pcPriClassBase       As Long 'Base priority of any threads created by this process.
   dwFlags              As Long 'Reserved; do not use.
   szExeFile            As String * MAX_PATH 'Path and filename of the executable file for the process.
End Type

Public Type MYPROCESSENTRY32
   dwSize               As Long 'Specifies the length, in bytes, of the structure.
   cntUsage             As Long 'Number of references to the process.
   th32ProcessID        As Long 'Identifier of the process.
   th32DefaultHeapID    As Long 'Identifier of the default heap for the process.
   th32ModuleID         As Long 'Module identifier of the process. (Associated exe)
   cntThreads           As Long 'Number of execution threads started by the process.
   th32ParentProcessID  As Long 'Identifier of the process that created the process being examined.
   pcPriClassBase       As Long 'Base priority of any threads created by this process.
   dwFlags              As Long 'Reserved; do not use.
   szExeFile            As String * MAX_PATH 'Path and filename of the executable file for the process.
   pathExe              As String
   procMode             As String
   ProcTime             As String
   QuitTime             As String
   procFlag             As Long '2: lost / 1: new / 3: both
End Type
   
Public Type MODULEENTRY32
    dwSize          As Long 'Specifies the length, in bytes, of the structure.
    th32ModuleID    As Long 'Module identifier in the context of the owning process.
    th32ProcessID   As Long 'Identifier of the process being examined.
    GlblcntUsage    As Long 'Global usage count on the module.
    ProccntUsage    As Long 'Module usage count in the context of the owning process.
    modBaseAddr     As Long 'Base address of the module in the context of the owning process.
    modBaseSize     As Long 'Size, in bytes, of the module.
    hModule         As Long 'Handle to the module in the context of the owning process.
    szModule        As String * MAX_MODULE_NAME32plus 'String containing the module name.
    szExePath       As String * MAX_PATH 'String containing the location (path) of the module.
End Type

Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type

Private Declare Function OleCreatePictureIndirect _
    Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function GetDC Lib "user32" ( _
    ByVal hwnd As Long) As Long

Private Declare Function GetWindowDC Lib "user32" ( _
    ByVal hwnd As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
    ByVal hDC As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
    ByVal hDC As Long, ByVal NWidth As Long, _
    ByVal NHeight As Long) As Long
    
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Declare Function GetSystemPaletteEntries Lib "gdi32" ( _
    ByVal hDC As Long, ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _
    As Long

Private Declare Function CreatePalette Lib "gdi32" ( _
    lpLogPalette As LOGPALETTE) As Long

Private Declare Function SelectPalette Lib "gdi32" ( _
    ByVal hDC As Long, ByVal hPalette As Long, _
    ByVal bForceBackground As Long) As Long

Private Declare Function RealizePalette Lib "gdi32" ( _
    ByVal hDC As Long) As Long

Private Declare Function BitBlt Lib "gdi32" ( _
    ByVal hDCDest As Long, ByVal XDest As Long, _
    ByVal YDest As Long, ByVal NWidth As Long, _
    ByVal NHeight As Long, ByVal hDCSrc As Long, _
    ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
    As Long

Private Declare Function DeleteDC Lib "gdi32" ( _
    ByVal hDC As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hwnd As Long, ByVal hDC As Long) As Long



Private Declare Function SelectObject Lib "gdi32" ( _
    ByVal hDC As Long, ByVal hObject As Long) As Long


Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Private Declare Function NtQuerySystemInformation Lib "ntdll" _
        (ByVal dwInfoType As Long, _
         ByVal lpStructure As Long, _
         ByVal dwSize As Long, _
         ByVal dwReserved As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
        Alias "RtlMoveMemory" _
        (Destination As Any, _
        Source As Any, _
        ByVal Length As Long)
        
Private Declare Function SHGetFolderPath Lib "shfolder" _
        Alias "SHGetFolderPathA" (ByVal HwndOwner As Long, _
        ByVal nFolder As Long, ByVal hToken As Long, _
        ByVal dwFlags As Long, ByVal pszPath As String) As Long

Private Declare Function GetVersionEx _
    Lib "kernel32" Alias "GetVersionExA" _
    (VersionInfo As OSVERSIONINFOEX) As Long

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" (ByVal hwnd As Long, _
    ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal Buffer As String, buffersize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal Buffer As String, buffersize As Long) As Long
Private Declare Function IsNTAdmin Lib "advpack.dll" (ByVal dwReserved As Long, ByRef lpdwReserved As Long) As Long

Public Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function EnumProcesses Lib "psapi.dll" _
   (ByRef lpidProcess As Long, ByVal cb As Long, _
      ByRef cbNeeded As Long) As Long
Public Declare Function OpenProcess Lib "kernel32.dll" _
  (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, _
      ByVal dwProcId As Long) As Long
      Public Declare Function EnumProcessModules Lib "psapi.dll" _
   (ByVal hProcess As Long, ByRef lphModule As Long, _
      ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function GetModuleFileNameExA Lib "psapi.dll" _
   (ByVal hProcess As Long, ByVal hModule As Long, _
      ByVal ModuleName As String, ByVal nSize As Long) As Long
Public Declare Function CloseHandle Lib "kernel32.dll" _
   (ByVal Handle As Long) As Long
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" ( _
   ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Public Declare Function Module32First Lib "kernel32" ( _
    ByVal hSnapShot As Long, lpme As MODULEENTRY32) As Long
Public Declare Function Module32Next Lib "kernel32" ( _
    ByVal hSnapShot As Long, lpme As MODULEENTRY32) As Long
Public Declare Function GetVersionExA Lib "kernel32" _
   (lpVersionInformation As OSVERSIONINFO) As Integer
Private Declare Function ProcessFirst Lib "kernel32" _
    Alias "Process32First" (ByVal hSnapShot As Long, _
    uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" _
    Alias "Process32Next" (ByVal hSnapShot As Long, _
    uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" _
    Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, _
    ByVal lProcessID As Long) As Long

Private Declare Function Process32First Lib "kernel32" ( _
    ByVal hSnapShot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" ( _
   ByVal hSnapShot As Long, lppe As PROCESSENTRY32) As Long
Private LiOldIdleTime   As LARGE_INTEGER
Private LiOldSystemTime  As LARGE_INTEGER

Private Type BrowseInfo
     HwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpBI As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long



Public Function Query() As Long
    Dim SysBaseInfo     As SYSTEM_BASIC_INFORMATION
    Dim SysPerInfo      As SYSTEM_PERFORMANCE_INFORMATION
    Dim SysTimeInfo     As SYSTEM_TIME_INFORMATION
    Dim dbIdleTime      As Currency
    Dim dbSystemTime    As Currency
    Dim Ret As Long

    Query = -1
        Ret = NtQuerySystemInformation(SYSTEM_BASICINFORMATION, VarPtr(SysBaseInfo), LenB(SysBaseInfo), 0&)
        If Ret <> NO_ERROR Then
            Debug.Print "Error on retrieving number of Processors", vbCritical
                Exit Function
        End If
        Ret = NtQuerySystemInformation(SYSTEM_PERFORMANCEINFORMATION, VarPtr(SysPerInfo), LenB(SysPerInfo), 0&)
        If Ret <> NO_ERROR Then
            Debug.Print "Error on retrieving Cpu's IdleTime", vbCritical
        End If
        Ret = NtQuerySystemInformation(SYSTEM_TIMEINFORMATION, VarPtr(SysTimeInfo), LenB(SysTimeInfo), ByVal 0&)
        If Ret <> NO_ERROR Then
            Debug.Print "Error on retrieving System Time", vbCritical
                Exit Function
        End If
        dbIdleTime = Li2Currency(SysPerInfo.LiIdleTime) _
                   - Li2Currency(LiOldIdleTime)
        dbSystemTime = Li2Currency(SysTimeInfo.LiKeSystemTime) _
                     - Li2Currency(LiOldSystemTime)
        If dbSystemTime <> 0 Then dbIdleTime = dbIdleTime / dbSystemTime
        dbIdleTime = 100 - dbIdleTime * 100 / SysBaseInfo.bKeNumberProcessors + 0.5
    Query = dbIdleTime
    LiOldIdleTime = SysPerInfo.LiIdleTime
    LiOldSystemTime = SysTimeInfo.LiKeSystemTime
End Function

Public Function MemoryLoad() As Long
Dim RAMTotal As Long
Dim DumpMem As MEMORYSTATUS
GlobalMemoryStatus DumpMem
RAMTotal = ((Int(DumpMem.dwTotalPhys / 1048576)) + 1)
MemoryLoad = (RAMUsed * 100) / RAMTotal
End Function

Public Function MemoryTotal() As Long
    Dim DumpMem As MEMORYSTATUS
    GlobalMemoryStatus DumpMem
    MemoryTotal = ((Int(DumpMem.dwTotalPhys / 1048576)) + 1)
End Function

Public Function RAMUsed() As Long
    Dim DumpMem As MEMORYSTATUS
    GlobalMemoryStatus DumpMem
    RAMUsed = (DumpMem.dwTotalPhys - DumpMem.dwAvailPhys) / BYTETOMB
End Function

Private Function Li2Currency(LiInput As LARGE_INTEGER) As Currency
    Call CopyMemory(Li2Currency, LiInput, LenB(LiInput))
End Function

Public Function mGetPath(mFolder As SpecialFolders) As String
    Dim strPath    As String
    Dim lngReturn  As Long
    Dim lngcsidl   As Long
    lngcsidl = mFolder
    strPath = String(MAX_PATH, 0)
    lngReturn = SHGetFolderPath(0, lngcsidl, 0, SHGFP_TYPE_CURRENT, strPath)
    Select Case lngReturn
        Case S_OK
            mGetPath = Left$(strPath, InStr(1, strPath, Chr(0)) - 1)
        Case Else
            mGetPath = ""
    End Select
End Function

Public Function WindowsVersion() As String
Dim VerInfo          As OSVERSIONINFOEX
Dim bOsVersionInfoEx As Long
    On Error Resume Next
    VerInfo.dwOSVersionInfoSize = Len(VerInfo)
    bOsVersionInfoEx = GetVersionEx(VerInfo)
    If bOsVersionInfoEx = 0 Then
        VerInfo.dwOSVersionInfoSize = OSVERSIONINFOSIZE
        Call GetVersionEx(VerInfo)
    End If
    Select Case VerInfo.dwPlatformId
        Case VER_PLATFORM_WIN32_NT
            If VerInfo.dwMajorVersion < 4 Then
                WindowsVersion = "Microsoft Windows NT 3 "
            ElseIf VerInfo.dwMajorVersion = 4 Then
                WindowsVersion = "Microsoft Windows NT 4 "
            ElseIf VerInfo.dwMajorVersion = 5 And VerInfo.dwMinorVersion = 0 Then
                WindowsVersion = "Microsoft Windows 2000 "
            ElseIf VerInfo.dwMajorVersion = 5 And VerInfo.dwMinorVersion = 1 Then
                WindowsVersion = "Microsoft Windows XP "
            End If
            
            If bOsVersionInfoEx Then
                If VerInfo.bProductType = VER_NT_WORKSTATION Then
                    If VerInfo.wSuiteMask And VER_SUITE_PERSONAL Then
                        WindowsVersion = WindowsVersion & "Home Edition "
                    Else
                        WindowsVersion = WindowsVersion & "Professional "
                    End If
                ElseIf VerInfo.bProductType = VER_NT_SERVER Then
                    If VerInfo.wSuiteMask And VER_SUITE_DATACENTER Then
                        WindowsVersion = WindowsVersion & "DataCenter Server "
                    ElseIf VerInfo.wSuiteMask And VER_SUITE_ENTERPRISE Then
                        WindowsVersion = WindowsVersion & "Advanced Server "
                    Else
                        WindowsVersion = WindowsVersion & "Server "
                    End If
                End If
            Else
                Select Case UCase$(GetSetting("SYSTEM\CurrentControlSet\Control\ProductOptions", "ProductType", 0))
                    Case "WINNT"
                        WindowsVersion = WindowsVersion & "Professional "
                    Case "LANMANNT"
                        WindowsVersion = WindowsVersion & "Server "
                    Case "SERVERNT"
                        WindowsVersion = WindowsVersion & "Advanced Server "
                End Select
            End If
            If VerInfo.dwMajorVersion <= 4 Then
                WindowsVersion = WindowsVersion & "version " & VerInfo.dwMajorVersion & "." & VerInfo.dwMinorVersion & VerInfo.szCSDVersion & " (Build " & VerInfo.dwBuildNumber And &HFFFF & ")"
            Else
                WindowsVersion = WindowsVersion & Trim$(VerInfo.szCSDVersion) & " (Build " & (VerInfo.dwBuildNumber And &HFFFF) & ")"
            End If
            WindowsVersion = WindowsVersion & ", service pack " & VerInfo.wServicePackMajor & "." & VerInfo.wServicePackMinor
    Case VER_PLATFORM_WIN32_WINDOWS
        If VerInfo.dwMajorVersion = 4 And VerInfo.dwMinorVersion = 0 Then
            WindowsVersion = "Microsoft Windows 95 "
            If InStr(1, VerInfo.szCSDVersion, "C", vbBinaryCompare) > 0 Or InStr(1, VerInfo.szCSDVersion, "B", vbBinaryCompare) > 0 Then
                WindowsVersion = WindowsVersion & "OSR2 "
            End If
        ElseIf VerInfo.dwMajorVersion = 4 And VerInfo.dwMinorVersion = 10 Then
            WindowsVersion = "Microsoft Windows 98 "
            
            If InStr(1, VerInfo.szCSDVersion, "A", vbBinaryCompare) > 0 Then
                WindowsVersion = WindowsVersion & "SE "
            End If
        ElseIf VerInfo.dwMajorVersion = 4 And VerInfo.dwMinorVersion = 90 Then
            WindowsVersion = "Microsoft Windows Me "
        End If
    
    Case VER_PLATFORM_WIN32s
        WindowsVersion = "Microsoft Win32s "
    Case Else
        WindowsVersion = "N/A"
    End Select
End Function

Public Function GetWorkArea() As RECT
    Dim TempWork As RECT
    Call SystemParametersInfo(SPI_GETWORKAREA, vbNull, TempWork, 0)
    GetWorkArea = TempWork
End Function

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal bClient As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory       As Long
    Dim hBmp            As Long
    Dim hBmpPrev        As Long
    Dim R               As Long
    Dim hDCSrc          As Long
    Dim hPal            As Long
    Dim hPalPrev        As Long
    Dim RasterCapsScrn  As Long
    Dim HasPaletteScrn  As Long
    Dim PaletteSizeScrn As Long
    Dim LogPal          As LOGPALETTE
    If bClient Then
        hDCSrc = GetDC(hWndSrc)
    Else
        hDCSrc = GetWindowDC(hWndSrc)
    End If
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        R = RealizePalette(hDCMemory)
    End If
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
        LeftSrc, TopSrc, vbSrcCopy)
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    R = DeleteDC(hDCMemory)
    R = ReleaseDC(hWndSrc, hDCSrc)
    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R   As Long
    Dim Pic As PicBmp
    Dim IPic          As IPicture
    Dim IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = vbPicTypeBitmap
        .hBmp = hBmp
        .hPal = hPal
    End With
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function

Public Function CaptureScreen() As Picture
    Dim hWndScreen As Long
    hWndScreen = GetDesktopWindow()
    With Screen
        Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _
               .Width \ .TwipsPerPixelX, .Height \ .TwipsPerPixelY)
    End With
End Function

Public Function CaptureObject(NObject As Object) As Picture
    With NObject
        Set CaptureObject = CaptureWindow(.hwnd, False, 0, 0, _
            .ScaleX(.Width, vbTwips, vbPixels), _
            .ScaleY(.Height, vbTwips, vbPixels))
    End With
End Function

Public Function CaptureClient(frm As Form) As Picture
    With frm
        Set CaptureClient = CaptureWindow(.hwnd, True, 0, 0, _
            .ScaleX(.ScaleWidth, .ScaleMode, vbPixels), _
            .ScaleY(.ScaleHeight, .ScaleMode, vbPixels))
    End With
End Function

Public Function CaptureActiveWindow() As Picture
    Dim hWndActive As Long
    Dim RectActive As RECT
    hWndActive = GetForegroundWindow()
    Call GetWindowRect(hWndActive, RectActive)
    With RectActive
        Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _
                .Right - .Left, .Bottom - .Top)
    End With
End Function

Public Function OpenFile(sFileName As String, Optional sOption As FILEOPTION = SW_SHOWNORMAL) As Long
    Dim lResult As Long
    If sFileName <> "" Then
        lResult = ShellExecute(0, "open", sFileName, "", 0, sOption)
    End If
    OpenFile = lResult
End Function

Public Function BrowseFolder(Folder As String, Optional sOption As FILEOPTION = SW_SHOWNORMAL)
    Dim lResult As Long
    If Folder <> "" Then
        lResult = ShellExecute(0, "EXPLORE", Folder, "", 0, sOption)
    End If
End Function

Public Function OpenURL(URL As String, Optional sOption As FILEOPTION = SW_SHOWNORMAL)
    Dim lResult
    If URL <> "" Then
        lResult = ShellExecute(0, "open", URL, "", 0, sOption)
    End If
End Function

Public Function SendMail(Address As String, Subject As String, Body As String, Optional CC As String = "", Optional BlindCC As String = "", Optional Attach As String, Optional sOption As FILEOPTION = SW_SHOWNORMAL)
    Dim sText As String
    Dim sAddedText As String
    If Len(Address) <= 0 Then Exit Function
    sText = Address
    If Len(CC) Then sAddedText = sAddedText & "&CC=" & CC
    If Len(BlindCC) Then sAddedText = sAddedText & "&BCC=" & BlindCC
    If Len(Subject) Then sAddedText = sAddedText & "&Subject=" & Subject
    If Len(Body) Then sAddedText = sAddedText & "&Body=" & Body
    If Len(Attach) Then sAddedText = sAddedText & "&Attach=" & Chr(34) & Attach & Chr(34)
    sText = "mailto:" & sText
    If Len(sAddedText) <> 0 Then Mid$(sAddedText, 1, 1) = "?"
    sText = sText & sAddedText
    If Len(sText) Then Call ShellExecute(0, "open", sText, _
        vbNullString, vbNullString, sOption)
End Function

'Public Function CreateShellLink(sLnkFile As String, sExeFile As String, sWorkDir As String, sExeArgs As String, sIconFile As String, lIconIdx As Long, showCmd As SHOWCMDFLAGS) As Long
'    Dim cShellLink   As ShellLinkA    ' An explorer IShellLinkA(Win 9x/Win NT) instance
'    Dim cPersistFile As IPersistFile ' An explorer IPersistFile instance
'    If (sLnkFile = "") Or (sExeFile = "") Then Exit Function
'    On Error GoTo fCreateShellLinkError
'    Set cShellLink = New ShellLinkA   'Create new IShellLink interface
'    Set cPersistFile = cShellLink     'Implement cShellLink's IPersistFile interface
'    With cShellLink
'        .SetPath sExeFile
'        If sWorkDir <> "" Then .SetWorkingDirectory sWorkDir
'        If sExeArgs <> "" Then .SetArguments sExeArgs
'        .SetDescription "ShellLink Sample" & vbNullChar
'        If sIconFile <> "" Then .SetIconLocation sIconFile, lIconIdx
'        .SetShowCmd showCmd
'    End With
'    cShellLink.Resolve 0, SLR_UPDATE
'    cPersistFile.Save StrConv(sLnkFile, vbUnicode), 0 'Unicode conversion that must be done!
'    CreateShellLink = True                            'Return Success
'
'fCreateShellLinkError:
'    Set cPersistFile = Nothing
'    Set cShellLink = Nothing
'End Function

Public Function UserName() As String
    Dim Buffer As String * 128
    GetUserName Buffer, 128
    UserName = Trim(Buffer)
End Function

Public Function ComputerName() As String
    Dim Buffer As String * 128
    On Error GoTo errhandler
    GetComputerName Buffer, 128
    ComputerName = Trim(Buffer)
    Exit Function
errhandler:
    ComputerName = "N/A"
    Exit Function
End Function

Public Function GetCPUInfo(TempInfo As PROCESSOR_INFORMATION) As Long
    Dim strComputer As String
    Dim objWMIService
    Dim colItems
    Dim objItem
    Dim AVG
    Dim GVA As Object
    On Error Resume Next
    strComputer = "."
    On Error Resume Next
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    On Error Resume Next
    Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor", , 48)
    For Each objItem In colItems
        TempInfo.CPUCaption = objItem.Caption
        TempInfo.CPUCurrentClockSpeed = Val(objItem.CurrentClockSpeed)
        TempInfo.CPUExtClock = Val(objItem.ExtClock)
        TempInfo.CPULevel = objItem.Level
        TempInfo.CPUManufacturer = objItem.Manufacturer
        TempInfo.CPUMaxClockSpeed = Val(objItem.MaxClockSpeed)
        TempInfo.CPUName = objItem.Name
        TempInfo.CPUStatus = objItem.Status
        DoEvents
        GetCPUInfo = 1
    Next
End Function

Public Function GetGraphicCard() As String
    Dim TempValue As String
    Dim strComputer, objWMIService, colItems, objItem
    On Error Resume Next
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Set colItems = objWMIService.ExecQuery("Select * from Win32_VideoController", , 48)
    For Each objItem In colItems
        TempValue = Trim(objItem.Name)
    Next
    GetGraphicCard = TempValue
End Function

Public Function GetUserAccount() As String
    Dim Actual As Boolean
    Actual = CBool(IsNTAdmin(ByVal 0&, ByVal 0&))
    If Actual = True Then
        GetUserAccount = "Administrator"
    Else
        GetUserAccount = "Restricted"
    End If
End Function

Public Function FillProcessListNT(lstBox As ListBox) As Long
'
' Clears the listbox and fill it with the
' processes and the modules used by each process.
'
Dim cb                As Long
Dim cbNeeded          As Long
Dim NumElements       As Long
Dim ProcessIDs()      As Long
Dim cbNeeded2         As Long
Dim NumElements2      As Long
Dim Modules(1 To 200) As Long
Dim lRet              As Long
Dim ModuleName        As String
Dim nSize             As Long
Dim hProcess          As Long
Dim i                 As Long
Dim sModName          As String
Dim sChildModName     As String
Dim iModDlls          As Long
Dim iProcesses        As Integer
    
lstBox.Clear
'
' Get the array containing the process id's for each process object.
'
cb = 8
cbNeeded = 96
'
' There is no way to find out how big the passed in array
' must be. EnumProcesses() will never return a value in
' cbNeeded that is larger than the size of array value
' that you passed in the cb parameter.
'
' If cbNeeded == cb upon return, allocate a larger array
' and try again until cbNeeded is smaller than cb.
'
Do While cb <= cbNeeded
    cb = cb * 2
    ReDim ProcessIDs(cb / 4) As Long
    lRet = EnumProcesses(ProcessIDs(1), cb, cbNeeded)
Loop
'
' Calculate how many process IDs were returned.
'
NumElements = cbNeeded / 4
    
For i = 1 To NumElements
    '
    ' Get a handle to the Process.
    '
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION _
            Or PROCESS_VM_READ, 0, ProcessIDs(i))
    '
    ' Iterate through each process with an ID that <> 0.
    '
    If hProcess Then
        '
        ' Get an array of the module handles for the specified process.
        '
        lRet = EnumProcessModules(hProcess, Modules(1), 200, cbNeeded2)
        '
        ' If the Module Array is retrieved, Get the ModuleFileName.
        '
        If lRet <> 0 Then
            '
            ' Fill the ModuleName buffer with spaces.
            '
            ModuleName = Space(MAX_PATH)
            '
            ' Preset buffer size.
            '
            nSize = 500
            '
            ' Get the module file name.
            '
            lRet = GetModuleFileNameExA(hProcess, Modules(1), ModuleName, nSize)
            '
            ' Get the module file name out of the buffer, lRet is how
            ' many characters the string is, the rest of the buffer is spaces.
            '
            sModName = Left$(ModuleName, lRet)
            '
            ' Add the process to the listbox.
            '
            lstBox.AddItem sModName
            '
            ' Increment the count of processes we've added.
            '
            iProcesses = iProcesses + 1
                
            iModDlls = 1
            Do
                iModDlls = iModDlls + 1
                '
                ' Fill the ModuleName buffer with spaces.
                '
                ModuleName = Space(MAX_PATH)
                '
                ' Preset buffer size.
                '
                nSize = 500
                '
                ' Get the module file name out of the buffer, lRet is how
                ' many characters the string is, the rest of the buffer is spaces.
                '
                lRet = GetModuleFileNameExA(hProcess, Modules(iModDlls), ModuleName, nSize)
                sChildModName = Left$(ModuleName, lRet)
                    
                If sChildModName = sModName Then Exit Do
                If Trim(sChildModName) <> "" Then lstBox.AddItem "    " & sChildModName
            Loop
        End If
    Else
        '
        ' Return the number of Processes found.
        '
        FillProcessListNT = 0
    End If
    '
    ' Close the handle to the process.
    '
    lRet = CloseHandle(hProcess)
Next
'
' Return the number of Processes found.
'
FillProcessListNT = iProcesses
End Function

Private Function StrZToStr(s As String) As String
   StrZToStr = Left$(s, Len(s) - 1)
End Function

Public Function FillProcessList9x(Optional lstBox As ListBox) As Long
    Dim lReturnID     As Long
    Dim hSnapProcess  As Long
    Dim hSnapModule   As Long
    Dim sName         As String
    Dim proc          As PROCESSENTRY32
    Dim Module        As MODULEENTRY32
    Dim iProcesses    As Integer
    Dim iModules      As Integer
    On Error Resume Next
    lstBox.Clear
    hSnapProcess = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
    If hSnapProcess = 0 Then
        FillProcessList9x = 0
    Else
        proc.dwSize = Len(proc)
        lReturnID = Process32First(hSnapProcess, proc)
        Do While lReturnID
            On Error Resume Next
            lstBox.AddItem StrZToStr(proc.szExeFile)
            iProcesses = iProcesses + 1
            hSnapModule = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, proc.th32ProcessID)
            If Not hSnapModule = 0 Then
                Module.dwSize = LenB(Module) - 1
                lReturnID = Module32First(hSnapModule, Module)
                Do While lReturnID
                    'lstBox.AddItem "    " & StrZToStr(module.szModule)
                    lReturnID = Module32Next(hSnapModule, Module)
                Loop
            End If
            Call CloseHandle(hSnapModule)
            lReturnID = Process32Next(hSnapProcess, proc)
        Loop
        Call CloseHandle(hSnapProcess)
        FillProcessList9x = iProcesses
    End If
End Function

Private Function GetVersion() As Long
    ' Returns the Operating System used
    ' 1 = Windows 9x
    ' 2 = Windows NT
    Dim OSInfo   As OSVERSIONINFO
    Dim retvalue As Integer
    With OSInfo
        .dwOSVersionInfoSize = 148
        .szCSDVersion = Space$(128)
        retvalue = GetVersionExA(OSInfo)
        GetVersion = .dwPlatformId
    End With
End Function

Public Function GraphicAdapter() As String
    Dim strComputer
    Dim objWMIService
    Dim colItems
    Dim objItem
    On Error Resume Next
    strComputer = "."
    On Error Resume Next
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    On Error Resume Next
    Set colItems = objWMIService.ExecQuery("Select * from Win32_VideoController", , 48)
    For Each objItem In colItems
        GraphicAdapter = objItem.Name
    Next
End Function

Public Function ScreenResolution() As String
    ScreenResolution = Screen.Width / Screen.TwipsPerPixelX & " x " & Screen.Height / Screen.TwipsPerPixelY
End Function

Public Function BrowseForFolder(HwndOwner As Long, sPrompt As String) As String
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo
     With udtBI
        .HwndOwner = HwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With
     lpIDList = SHBrowseForFolder(udtBI)
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If
     BrowseForFolder = sPath
End Function

Public Function KillProcess(ByVal kpProcId As Long)
    Dim lPid
    Dim lProcess
    Dim lReturn
    lPid = kpProcId
    lProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lPid)
    lReturn = TerminateProcess(lProcess, 0&)
End Function

Public Function GetProcessIDFromHwnd(ByVal hwnd As Long) As Long
    Dim TmpID As Long
    GetWindowThreadProcessId hwnd, TmpID
    GetProcessIDFromHwnd = TmpID
End Function

Public Function GetPreviousDir(ByVal ePath As String) As String
    If Len(ePath) < 2 Then Exit Function
    Dim CurPos As Long
    Dim sGot() As String
    sGot = Split(ePath, "\")
    CurPos = UBound(sGot) - 1
    If CurPos >= 0 Then
        GetPreviousDir = sGot(CurPos)
    Else
        GetPreviousDir = ePath
    End If
End Function

Public Function GetDirParent(ByVal ePath As String) As String
    If Len(ePath) < 2 Then
        GetDirParent = ePath
        Exit Function
    End If
    If Len(ePath) = 2 Then
        GetDirParent = ePath
        Exit Function
    End If
    Dim CurPos As Long
    Dim sGot() As String
    Dim Cnt As Long
    sGot = Split(ePath, "\")
    CurPos = UBound(sGot) - 1
    If CurPos >= 0 Then
        For Cnt = 0 To CurPos
            GetDirParent = GetDirParent & sGot(Cnt) & "\"
        Next Cnt
    End If
    GetDirParent = Left(GetDirParent, Len(GetDirParent) - 1)
End Function
