Shady
Level: VB Guru
Registered: 08-07-2002
Posts: 305
|
Getting Hardware Info
It seems that obtaining information about your systems seems to be quite a common request, so for those of you who need some help, here are some functions I found from around the internet.
Private Declare Sub GetSystemInfo _
Lib "kernel32" _
(lpSystemInfo As SYSTEM_INFO)
Private Declare Function IsProcessorFeaturePresent _
Lib "kernel32" _
(ByVal ProcessorFeature As Long) _
As Long
Private Declare Function GetSystemMetrics _
Lib "user32" _
(ByVal nIndex As Long) _
As Long
Private Type SYSTEM_INFO
wProcessorArchitecture As Integer
wReserved As Integer
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
wProcessorLevel As Integer
wProcessorRevision As Integer
End Type
Private Const SM_SLOWMACHINE = 73
Private Const PF_FLOATING_POINT_PRECISION_ERRATA = 0
Private Const PF_FLOATING_POINT_EMULATED = 1
Private Const PF_COMPARE_EXCHANGE_DOUBLE = 2
Private Const PF_MMX_INSTRUCTIONS_AVAILABLE = 3
Public Enum EnumProcessorType
cmiIntel386 = 386
cmiIntel486 = 486
cmiIntelPENTIUM = 586
cmiMIPSR4000 = 4000
cmiALPHA21064 = 21064
End Enum
Public Enum EnumProcessorArchitecture
cmiIntel = 0
cmiMIPS = 1
cmiALPHA = 2
cmiPPC = 3
cmiUnknown = &HFFFF
End Enum
Property Get ActiveProcessorMask() As Long
' Returns : The active processors in the system
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
ActiveProcessorMask = si.dwActiveProcessorMask
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ActiveProcessorMask"
Resume PROC_EXIT
End Property
Property Get AllocationGranularity() As Long
' Returns : The granularity with which virtual memory is allocated.
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
AllocationGranularity = si.dwAllocationGranularity
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"AllocationGranularity"
Resume PROC_EXIT
End Property
Property Get CompareExchangeDouble() As Boolean
' Returns : True if the compare and exchange double operation is available
' False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
CompareExchangeDouble = _
IsProcessorFeaturePresent(PF_COMPARE_EXCHANGE_DOUBLE)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CompareExchangeDouble"
Resume PROC_EXIT
End Property
Property Get FloatingPointEmulated() As Boolean
' Returns : True if floating point emulation is used, False if it is not
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
FloatingPointEmulated = _
IsProcessorFeaturePresent(PF_FLOATING_POINT_EMULATED)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"FloatingPointEmulated"
Resume PROC_EXIT
End Property
Property Get FloatingPointError() As Boolean
' Returns : True if the pentium floating point bug exists in this processor
' False if it does not
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
FloatingPointError = _
IsProcessorFeaturePresent(PF_FLOATING_POINT_PRECISION_ERRATA)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"FloatingPointError"
Resume PROC_EXIT
End Property
Property Get LowMemory() As Boolean
' Returns : True if the computer is considered a low memory machine, False
' if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
' The following flags are defined for the return value of the
' GetSystemMetrics(SM_SLOWMACHINE) function
'
' &H0001 - CPU is a 386
' &H0002 - low memory machine (less than 5 megabytes)
' &H0004 - slow (non-accelerated) display card
LowMemory = (GetSystemMetrics(SM_SLOWMACHINE) And 2) > 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LowMemory"
Resume PROC_EXIT
End Property
Property Get MaxAppAddress() As Long
' Returns : the highest memory address accessible to applications and DLLs.
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
MaxAppAddress = si.lpMaximumApplicationAddress
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MaxAppAddress"
Resume PROC_EXIT
End Property
Property Get MinAppAddress() As Long
' Returns : the lowest memory address accessible to applications and DLLs.
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
MinAppAddress = si.lpMinimumApplicationAddress
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MinAppAddress"
Resume PROC_EXIT
End Property
Property Get MMXAvailable() As Boolean
' Returns : True if the processor supports MMX, False if it does not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
MMXAvailable = _
IsProcessorFeaturePresent(PF_MMX_INSTRUCTIONS_AVAILABLE)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MMXAvailable"
Resume PROC_EXIT
End Property
Property Get NumberOfProcessors() As Long
' Returns : The number of processors in the system
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
NumberOfProcessors = si.dwNumberOfProcessors
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"NumberOfProcessors"
Resume PROC_EXIT
End Property
Property Get PageSize() As Long
' Returns : Indicate the page size.
' Source: Total VB SourceBook 6
'
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
PageSize = si.dwPageSize
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"PageSize"
Resume PROC_EXIT
End Property
Property Get ProcessorArchitecture() As EnumProcessorArchitecture
' Returns : The processor architecture
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
ProcessorArchitecture = si.wProcessorArchitecture
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ProcessorArchitecture"
Resume PROC_EXIT
End Property
Property Get ProcessorLevel() As Long
' Returns : The system's architecture-dependent processor level
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
ProcessorLevel = si.wProcessorLevel
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ProcessorLevel"
Resume PROC_EXIT
End Property
Property Get ProcessorRevision() As Long
' Returns : The architecture-dependent processor revision.
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
ProcessorRevision = si.wProcessorRevision
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ProcessorRevision"
Resume PROC_EXIT
End Property
Property Get ProcessorType() As EnumProcessorType
' Returns : The processor type
' Source: Total VB SourceBook 6
Dim si As SYSTEM_INFO
On Error GoTo PROC_ERR
GetSystemInfo si
ProcessorType = si.dwProcessorType
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ProcessorType"
Resume PROC_EXIT
End Property
Property Get SlowGraphics() As Boolean
' Returns : True if the graphics are considered slow, False if they are not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
' The following flags are defined for the return value of the
' GetSystemMetrics(SM_SLOWMACHINE) function
'
' &H0001 - CPU is a 386
' &H0002 - low memory machine (less than 5 megabytes)
' &H0004 - slow (non-accelerated) display card
SlowGraphics = (GetSystemMetrics(SM_SLOWMACHINE) And 4) > 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SlowGraphics"
Resume PROC_EXIT
End Property
Property Get SlowMachine() As Boolean
' Returns : True if the computer is considered a slow machine, False if it
' is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
' The following flags are defined for the return value of the
' GetSystemMetrics(SM_SLOWMACHINE) function
'
' &H0001 - CPU is a 386
' &H0002 - low memory machine (less than 5 megabytes)
' &H0004 - slow (non-accelerated) display card
SlowMachine = (GetSystemMetrics(SM_SLOWMACHINE) And 1) > 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SlowMachine"
Resume PROC_EXIT
End Property
|
and here's some for the keyboard
Private Declare Function GetKeyState _
Lib "user32" _
(ByVal nVirtKey As Long) _
As Integer
Private Declare Function SetKeyboardState _
Lib "user32" _
(lppbKeyState As Byte) _
As Long
Private Declare Function GetKeyboardType _
Lib "user32" _
(ByVal nTypeFlag As Long) _
As Long
Private Declare Function GetKeyboardState _
Lib "user32" _
(pbKeyState As Byte) _
As Long
Private Declare Function GetCaretBlinkTime _
Lib "user32" () _
As Long
Private Declare Function SetCaretBlinkTime _
Lib "user32" _
(ByVal wMSeconds As Long) _
As Long
Private Declare Function SystemParametersInfo _
Lib "user32" _
Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Long, _
ByVal fuWinIni As Long) _
As Long
Private Const VK_NUMLOCK = &H90
Private Const VK_SCROLL = &H91
Private Const VK_CAPITAL = &H14
Private Const VK_SHIFT = &H10
Private Const VK_CONTROL = &H11
Private Const VK_MENU = &H12
Private Const VK_LCONTROL = &HA2
Private Const VK_LMENU = &HA4
Private Const VK_LSHIFT = &HA0
Private Const VK_RMENU = &HA5
Private Const VK_RSHIFT = &HA1
Private Const VK_RCONTROL = &HA3
Private Const SPI_GETKEYBOARDDELAY = 22
Private Const SPI_GETKEYBOARDSPEED = 10
Private Const SPI_SETKEYBOARDDELAY = 23
Private Const SPI_SETKEYBOARDSPEED = 11
Private Const SPIF_SENDWININICHANGE = &H2
Public Enum EnumKeyboardType
kybIBM83Key = 1
kybICO102Key = 2
kybIBM84KEY = 3
kybIBM101Or102Key = 4
kybNokia1050 = 5
kybNokia9140 = 6
kybJapanese = 7
End Enum
Public Enum EnumKeyboardDelay
kybDelay250ms = 0
kybDelay500ms = 1
kybDelay750ms = 2
kybDelay1000ms = 3
End Enum
Property Get Alt() As Boolean
' Returns : True if Alt is pressed, False if it is not. This property
' does not distinguish between left and right keys
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
Alt = GetKeyState(VK_MENU) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Alt"
Resume PROC_EXIT
End Property
Property Get BlinkTime() As Integer
' Returns : The blink time of the caret, in milliseconds
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
BlinkTime = GetCaretBlinkTime
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"BlinkTime"
Resume PROC_EXIT
End Property
Property Let BlinkTime(ByVal intValue As Integer)
' intValue: The blink time of the caret, in milliseconds
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SetCaretBlinkTime intValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"BlinkTime"
Resume PROC_EXIT
End Property
Property Get CapsLock() As Boolean
' Returns : True if capslock is toggled on, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
CapsLock = (GetKeyState(VK_CAPITAL) And 1) = 1
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CapsLock"
Resume PROC_EXIT
End Property
Property Let CapsLock(ByVal fValue As Boolean)
' fValue: Sets the toggle state of the capslock key
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SetKeyState VK_CAPITAL, fValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CapsLock"
Resume PROC_EXIT
End Property
Property Get Control() As Boolean
' Returns : True if Control is pressed, False if it is not. This property
' does not distinguish between left and right keys
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
Control = GetKeyState(VK_CONTROL) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Control"
Resume PROC_EXIT
End Property
Property Get FunctionKeys() As Integer
' Returns : The number of function keys available
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
FunctionKeys = GetKeyboardType(2)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"FunctionKeys"
Resume PROC_EXIT
End Property
Property Get KeyboardType() As EnumKeyboardType
' Returns : The type of keyboard
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
KeyboardType = GetKeyboardType(0)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"KeyboardType"
Resume PROC_EXIT
End Property
Property Get LAlt() As Boolean
' Returns : True if the left Alt key is pressed, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
LAlt = GetKeyState(VK_LMENU) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LAlt"
Resume PROC_EXIT
End Property
Property Get LControl() As Boolean
' Returns : True if the left Control key is pressed, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
LControl = GetKeyState(VK_LCONTROL) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LControl"
Resume PROC_EXIT
End Property
Property Get LShift() As Boolean
' Returns : True if the left Shift key is pressed, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
LShift = GetKeyState(VK_LSHIFT) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LShift"
Resume PROC_EXIT
End Property
Property Get NumLock() As Boolean
' Returns : True if numlock is toggled on, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
NumLock = (GetKeyState(VK_NUMLOCK) And 1) = 1
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"NumLock"
Resume PROC_EXIT
End Property
Property Let NumLock(ByVal fValue As Boolean)
' fValue: Sets the toggle state of the numlock key
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SetKeyState VK_NUMLOCK, fValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"NumLock"
Resume PROC_EXIT
End Property
Property Get RAlt() As Boolean
' Returns : True if the right Alt key is pressed, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
RAlt = GetKeyState(VK_RMENU) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RAlt"
Resume PROC_EXIT
End Property
Property Get RControl() As Boolean
' Returns : True if the right Control key is pressed, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
RControl = GetKeyState(VK_RCONTROL) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RControl"
Resume PROC_EXIT
End Property
Property Get RepeatDelay() As EnumKeyboardDelay
' Returns : Returns the keyboard repeat delay
' Source: Total VB SourceBook 6
Dim lngOutValue As Long
On Error GoTo PROC_ERR
SystemParametersInfo SPI_GETKEYBOARDDELAY, 0, lngOutValue, 0
RepeatDelay = lngOutValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RepeatDelay"
Resume PROC_EXIT
End Property
Property Let RepeatDelay(ByVal eValue As EnumKeyboardDelay)
' eValue: Sets the Keyboard repeat delay
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SystemParametersInfo SPI_SETKEYBOARDDELAY, eValue, 0, SPIF_SENDWININICHANGE
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RepeatDelay"
Resume PROC_EXIT
End Property
Property Get RepeatSpeed() As Integer
' Returns : The keyboard repeat speed
' Source: Total VB SourceBook 6
Dim lngOutValue As Long
On Error GoTo PROC_ERR
SystemParametersInfo SPI_GETKEYBOARDSPEED, 0, lngOutValue, 0
RepeatSpeed = lngOutValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RepeatSpeed"
Resume PROC_EXIT
End Property
Property Let RepeatSpeed(ByVal intValue As Integer)
' intValue: Sets the keyboard repeat speed
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SystemParametersInfo SPI_SETKEYBOARDSPEED, intValue, 0, SPIF_SENDWININICHANGE
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RepeatSpeed"
Resume PROC_EXIT
End Property
Property Get RShift() As Boolean
' Returns : True if the right Shift key is pressed, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
RShift = GetKeyState(VK_RSHIFT) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RShift"
Resume PROC_EXIT
End Property
Property Get ScrollLock() As Boolean
' Returns : True if scrolllock is toggled on, False if it is not
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
ScrollLock = (GetKeyState(VK_SCROLL) And 1) = 1
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ScrollLock"
Resume PROC_EXIT
End Property
Property Let ScrollLock(ByVal fValue As Boolean)
' fValue: Sets the toggle state of the ScrollLock key
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SetKeyState VK_SCROLL, fValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ScrollLock"
Resume PROC_EXIT
End Property
Property Get Shift() As Boolean
' Returns : True if Shift is pressed, False if it is not. This property
' does not distinguish between left and right keys
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
Shift = GetKeyState(VK_SHIFT) < 0
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Shift"
Resume PROC_EXIT
End Property
Private Sub SetKeyState(intKey As Integer, fValue As Boolean)
' Comments : This procedure sets the toggle state of a key
' Parameters: intKey - The key to set the state for
' fValue - The toggle state to set the key to
' Returns : Nothing
' Source : Total VB SourceBook 6
'
Dim abKeys(255) As Byte
On Error GoTo PROC_ERR
' Get the state of the keyboard
GetKeyboardState abKeys(0)
' Toggle the low bit
If fValue Then
abKeys(intKey) = abKeys(intKey) Or 1
Else
abKeys(intKey) = abKeys(intKey) And &HFE
End If
' set the new keyboard state
SetKeyboardState abKeys(0)
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SetKeyState"
Resume PROC_EXIT
End Sub
|
and now some for the memory
Private Declare Sub GlobalMemoryStatus _
Lib "kernel32" _
(lpBuffer As MemoryStatus)
Private Type MemoryStatus
dwLength As Long ' The size of the structure
dwMemoryLoad As Long ' Percent of memory in use
dwTotalPhys As Long ' bytes of physical memory
dwAvailPhys As Long ' bytes of free physical memory
dwTotalPageFile As Long ' bytes of paging file
dwAvailPageFile As Long ' bytes of free paging file
dwTotalVirtual As Long ' user bytes of address space
dwAvailVirtual As Long ' free user bytes
End Type
Property Get AvailablePageFile() As Long
' Returns : The available page file size in bytes
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
AvailablePageFile = typMemory.dwAvailPageFile
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"AvailablePageFile"
Resume PROC_EXIT
End Property
Property Get AvailablePhysical() As Long
' Returns : The available physical memory in bytes
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
AvailablePhysical = typMemory.dwAvailPhys
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"AvailablePhysical"
Resume PROC_EXIT
End Property
Property Get AvailableVirtual() As Long
' Returns : The available virtual memory in bytes
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
AvailableVirtual = typMemory.dwAvailVirtual
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"AvailableVirtual"
Resume PROC_EXIT
End Property
Property Get MemoryLoad() As Long
' Returns : The memory utilization. This is a value between 0 and 100.
' 0 indicates no memory used, and 100 indicates all memory is
' used
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
MemoryLoad = typMemory.dwMemoryLoad
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MemoryLoad"
Resume PROC_EXIT
End Property
Property Get TotalPageFile() As Long
' Returns : The page file size in bytes
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
TotalPageFile = typMemory.dwTotalPageFile
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"TotalPageFile"
Resume PROC_EXIT
End Property
Property Get TotalPhysical() As Long
' Returns : The total physical memory in bytes
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
TotalPhysical = typMemory.dwTotalPhys
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"TotalPhysical"
Resume PROC_EXIT
End Property
Property Get TotalVirtual() As Long
' Returns : The total virtual memory in bytes
' Source: Total VB SourceBook 6
'
Dim typMemory As MemoryStatus
On Error GoTo PROC_ERR
' Must set the length field before calling GlobalMemoryStatus
typMemory.dwLength = Len(typMemory)
GlobalMemoryStatus typMemory
' Return the appropriate field from the MemoryStatus type
TotalVirtual = typMemory.dwTotalVirtual
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"TotalVirtual"
Resume PROC_EXIT
End Property
|
and finally the operating system
Private Declare Function GetUserDefaultLCID _
Lib "kernel32" () _
As Long
Private Declare Function GetLocaleInfo _
Lib "kernel32" _
Alias "GetLocaleInfoA" _
(ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long) As Long
Private Declare Function CoCreateGuid _
Lib "ole32.dll" _
(pGUID As GUID) _
As Long
Private Declare Function SetComputerName _
Lib "kernel32" _
Alias "SetComputerNameA" _
(ByVal lpComputerName As String) _
As Long
Private Declare Function GetComputerName _
Lib "kernel32" _
Alias "GetComputerNameA" _
(ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Declare Function GetWindowsDirectory _
Lib "kernel32" _
Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Private Declare Function GetSystemDirectory _
Lib "kernel32" _
Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Private Declare Function GetTempPath _
Lib "kernel32" _
Alias "GetTempPathA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) _
As Long
Private Declare Function GetTempFileName _
Lib "kernel32" _
Alias "GetTempFileNameA" _
(ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) _
As Long
Private Declare Function GetUserName _
Lib "advapi32.dll" _
Alias "GetUserNameA" _
(ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Declare Function GetVersionEx _
Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) _
As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nIndex As Long) _
As Long
Private Declare Function GetDC _
Lib "user32" _
(ByVal hwnd As Long) _
As Long
Private Declare Function ReleaseDC _
Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) _
As Long
Private Declare Function SystemParametersInfo _
Lib "user32" _
Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Long, _
ByVal fuWinIni As Long) _
As Long
Private Declare Function GetCurrentHwProfile _
Lib "advapi32" _
Alias "GetCurrentHwProfileA" _
(HwProfileInfo As HW_PROFILE_INFO) _
As Long
Private Declare Function RegOpenKeyEx _
Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal lngHKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) _
As Long
Private Declare Function RegQueryValueExString _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As String, _
lpcbData As Long) _
As Long
Private Declare Function RegQueryValueExLong _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Long, _
lpcbData As Long) _
As Long
Private Declare Function RegQueryValueExBinary _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey 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 RegQueryValueExNULL _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey 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 RegCloseKey _
Lib "advapi32.dll" _
(ByVal lngHKey As Long) _
As Long
Private Const HW_PROFILE_GUIDLEN = 39
Private Const MAX_PROFILE_LEN = 80
Private Const MAX_PATH = 260
Private Const BITSPIXEL = 12
Private Const PLANES = 14
Private Const LOGPIXELSX& = 88
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const SPI_GETBEEP = 1
Private Const SPI_SETBEEP = 2
Private Const SPI_GETWORKAREA = 48
Private Const SPI_GETSCREENSAVEACTIVE = 16
Private Const SPI_GETSCREENSAVETIMEOUT = 14
Private Const SPI_SETSCREENSAVEACTIVE = 17
Private Const SPI_SETSCREENSAVETIMEOUT = 15
Private Const SPIF_SENDWININICHANGE = &H2
Private Const DOCKINFO_UNDOCKED = 1
Private Const DOCKINFO_DOCKED = 2
Private Const DOCKINFO_USER_SUPPLIED = 4
Private Const DOCKINFO_USER_UNDOCKED = 5
Private Const DOCKINFO_USER_DOCKED = 6
Private Const LOCALE_SENGLANGUAGE = &H1001 ' English name of language
'Registry
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const mcregErrorNone = 0
Private Const mcregErrorBadDB = 1
Private Const mcregErrorBadKey = 2
Private Const mcregErrorCantOpen = 3
Private Const mcregErrorCantRead = 4
Private Const mcregErrorCantWrite = 5
Private Const mcregErrorOutOfMemory = 6
Private Const mcregErrorInvalidParameter = 7
Private Const mcregErrorAccessDenied = 8
Private Const mcregErrorInvalidParameterS = 87
Private Const mcregErrorNoMoreItems = 259
Private Const mcregKeyAllAccess = &H3F
Private Const mcregKeyQueryValue = &H1
Private Const mcregOptionNonVolatile = 0
Private Const mcregSZ As Long = 1
Private Const mcregBinary As Long = 3
Private Const mcregDWord As Long = 4
Private Type HW_PROFILE_INFO
dwDockInfo As Long
szHwProfileGuid As String * HW_PROFILE_GUIDLEN
szHwProfileName As String * MAX_PROFILE_LEN
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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Enum EnumWindowsType
OSIWindows32s = 0
OSIWindows95 = 1
OSIWindowsNT = 2
End Enum
Property Get Beep() As Boolean
' Returns : True if the warning beeper is on, False if it is off
' Source: Total VB SourceBook 6
Dim lngReturnValue As Long
On Error GoTo PROC_ERR
SystemParametersInfo SPI_GETBEEP, 0, lngReturnValue, 0
Beep = lngReturnValue * -1
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Beep"
Resume PROC_EXIT
End Property
Property Let Beep(ByVal fValue As Boolean)
' fValue : Sets the warning beeper on or off
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
SystemParametersInfo SPI_SETBEEP, fValue * 1, 0, SPIF_SENDWININICHANGE
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Beep"
Resume PROC_EXIT
End Property
Property Get ComputerName() As String
' Returns : The computer name
' Source: Total VB SourceBook 6
Const cintStringLength As Integer = 100
Dim strComputerName As String * cintStringLength
On Error GoTo PROC_ERR
GetComputerName strComputerName, cintStringLength
ComputerName = TrimNulls(strComputerName)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ComputerName"
Resume PROC_EXIT
End Property
Property Let ComputerName(ByVal strValue As String)
' strValue : Sets the computer name
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SetComputerName strValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ComputerName"
Resume PROC_EXIT
End Property
Property Get CurrentHardwareProfile() As String
' Returns : The name of the current hardware profile
' Source: Total VB SourceBook 6
Dim hw As HW_PROFILE_INFO
On Error GoTo PROC_ERR
GetCurrentHwProfile hw
CurrentHardwareProfile = TrimNulls(hw.szHwProfileName)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CurrentHardwareProfile"
Resume PROC_EXIT
End Property
Property Get DefaultCompanyName() As String
' Returns : The default company name used by Microsoft setup programs
' Source: Total VB SourceBook 6
Const cstrKey As String = "Software\Microsoft\MS Setup (ACME)\User Info"
Const cstrValue As String = "DefCompany"
On Error GoTo PROC_ERR
DefaultCompanyName = RegistryGetKeyValue(HKEY_CURRENT_USER, cstrKey, _
cstrValue)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"DefaultCompanyName"
Resume PROC_EXIT
End Property
Property Get DefaultUserName() As String
' Returns : The default user name used by Microsoft setup programs
' Source: Total VB SourceBook 6
Const cstrKey As String = "Software\Microsoft\MS Setup (ACME)\User Info"
Const cstrValue As String = "DefName"
On Error GoTo PROC_ERR
DefaultUserName = RegistryGetKeyValue(HKEY_CURRENT_USER, cstrKey, cstrValue)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"DefaultUserName"
Resume PROC_EXIT
End Property
Property Get DisplayColors() As Long
' Returns : The number of colors displayed by the adapter
' Source: Total VB SourceBook 6
'
Dim lnghDC As Long
Dim lngTmp As Long
Dim lngBitsPerPixel As Long
On Error GoTo PROC_ERR
lnghDC = GetDC(0)
lngBitsPerPixel = GetDeviceCaps(lnghDC, BITSPIXEL) * _
GetDeviceCaps(lnghDC, PLANES)
lngTmp = ReleaseDC(0, lnghDC)
If lngBitsPerPixel = 32 Then
' True Color mode
DisplayColors = -1
Else
DisplayColors = 2& ^ lngBitsPerPixel
End If
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"DisplayColors"
Resume PROC_EXIT
End Property
Public Property Get GUID() As String
' Comments : Generates a GUID (Globally Unique IDentifier)
' Parameters: None
' Returns : Returns a string representation of the GUID
' Source: Total VB SourceBook 6
'
Dim typGUID As GUID
Dim strGUID As String
On Error GoTo PROC_ERR
CoCreateGuid typGUID
strGUID = "{" & Hex$(typGUID.Data1) & "-" & _
Hex$(typGUID.Data2) & "-" & _
Hex$(typGUID.Data3) & "-" & _
Hex$(typGUID.Data4(0)) & _
Hex$(typGUID.Data4(1)) & _
Hex$(typGUID.Data4(2)) & _
Hex$(typGUID.Data4(3)) & _
Hex$(typGUID.Data4(4)) & _
Hex$(typGUID.Data4(5)) & _
Hex$(typGUID.Data4(6)) & _
Hex$(typGUID.Data4(7)) & _
"}"
GUID = strGUID
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"GUID"
Resume PROC_EXIT
End Property
Property Get Language() As String
' Returns : This property returns the user language
' Source : Total VB SourceBook 6
'
On Error GoTo PROC_ERR
Const cintLangSize As Integer = 100
Dim strLanguage As String
strLanguage = Space(cintLangSize)
'intLangID = GetUserDefaultLCID()
GetLocaleInfo GetUserDefaultLCID, LOCALE_SENGLANGUAGE, strLanguage, _
cintLangSize
Language = TrimNulls(strLanguage)
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Language"
Resume PROC_EXIT
End Property
Property Get LargeFonts() As Boolean
' Returns : True if large fonts are displayed, False if small fonts are
' displayed
' Source: Total VB SourceBook 6
Dim lnghDC As Long
Dim lngLogPixelsX As Long
On Error GoTo PROC_ERR
lnghDC = GetDC(0)
lngLogPixelsX = GetDeviceCaps(lnghDC, LOGPIXELSX)
ReleaseDC 0, lnghDC
' If the pixels per inch = 120, then large fonts are in use
LargeFonts = (lngLogPixelsX = 120)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LargeFonts"
Resume PROC_EXIT
End Property
Property Get OSAdditional() As String
' Returns : Additional Information about the operating system version
' Source: Total VB SourceBook 6
Dim typVersion As OSVERSIONINFO
On Error GoTo PROC_ERR
typVersion.dwOSVersionInfoSize = Len(typVersion)
GetVersionEx typVersion
OSAdditional = TrimNulls(typVersion.szCSDVersion)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OSAdditional"
Resume PROC_EXIT
End Property
Property Get OSBuild() As Long
' Returns : The operating system build number
' Source: Total VB SourceBook 6
Dim typVersion As OSVERSIONINFO
Const BuildMask As Long = &H8000
On Error GoTo PROC_ERR
typVersion.dwOSVersionInfoSize = Len(typVersion)
GetVersionEx typVersion
OSBuild = typVersion.dwBuildNumber And Not BuildMask
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OSBuild"
Resume PROC_EXIT
End Property
Property Get OSMajorVersion() As Long
' Returns : The operating system major version
' Source: Total VB SourceBook 6
Dim typVersion As OSVERSIONINFO
On Error GoTo PROC_ERR
typVersion.dwOSVersionInfoSize = Len(typVersion)
GetVersionEx typVersion
OSMajorVersion = typVersion.dwMajorVersion
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OSMajorVersion"
Resume PROC_EXIT
End Property
Property Get OSMinorVersion() As Long
' Returns : The operating system minor version
' Source: Total VB SourceBook 6
Dim typVersion As OSVERSIONINFO
On Error GoTo PROC_ERR
typVersion.dwOSVersionInfoSize = Len(typVersion)
GetVersionEx typVersion
OSMinorVersion = typVersion.dwMinorVersion
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OSMinorVersion"
Resume PROC_EXIT
End Property
Property Get ScreenSaverActive() As Boolean
' Returns : True if screen saving is enabled, False if it is not
' Source: Total VB SourceBook 6
Dim lngOutValue As Long
On Error GoTo PROC_ERR
SystemParametersInfo SPI_GETSCREENSAVEACTIVE, 0, lngOutValue, 0
ScreenSaverActive = lngOutValue * -1
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ScreenSaverActive"
Resume PROC_EXIT
End Property
Property Let ScreenSaverActive(ByVal fValue As Boolean)
' fValue : Sets screen saving on or off
' Source: Total VB SourceBook 6
On Error GoTo PROC_ERR
SystemParametersInfo SPI_SETSCREENSAVEACTIVE, fValue * 1, 0, _
SPIF_SENDWININICHANGE
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ScreenSaverActive"
Resume PROC_EXIT
End Property
Property Get ScreenSaverTimeout() As Long
' Returns : The screen saver time-out value, in seconds
' Source: Total VB SourceBook 6
Dim lngReturnValue As Long
On Error GoTo PROC_ERR
SystemParametersInfo SPI_GETSCREENSAVETIMEOUT, 0, lngReturnValue, 0
ScreenSaverTimeout = lngReturnValue
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ScreenSaverTimeout"
Resume PROC_EXIT
End Property
Property Let ScreenSaverTimeout(ByVal lngValue As Long)
' lngValue : Sets the screen saver timeout, in seconds
' Source: Total VB SourceBook 6
'
On Error GoTo PROC_ERR
SystemParametersInfo SPI_SETSCREENSAVETIMEOUT, lngValue * 1, 0, _
SPIF_SENDWININICHANGE
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"ScreenSaverTimeout"
Resume PROC_EXIT
End Property
Property Get SystemDirectory() As String
' Returns : The windows system directory
' Source: Total VB SourceBook 6
Dim strSystemDirectory As String * MAX_PATH
On Error GoTo PROC_ERR
GetSystemDirectory strSystemDirectory, MAX_PATH
SystemDirectory = TrimNulls(strSystemDirectory)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SystemDirectory"
Resume PROC_EXIT
End Property
Property Get TempFile(strPrefix As String) As String
' Returns : A temporary file name based on the value of strPrefix.
' Source: Total VB SourceBook 6
'
Dim strTemp As String
Dim lngRet As Long
Dim strTempPath As String
On Error GoTo PROC_ERR
strTempPath = Space$(255)
lngRet = GetTempPath(Len(strTempPath), strTempPath)
strTemp = Space$(255)
lngRet = GetTempFileName(strTempPath, strPrefix, 1, ByVal strTemp)
TempFile = TrimNulls(strTemp)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"TempFile"
Resume PROC_EXIT
End Property
Property Get TempPath() As String
' Returns : The path of the temporary directory
' Source: Total VB SourceBook 6
Dim lngRet As Long
Dim strTempPath As String
On Error GoTo PROC_ERR
strTempPath = Space$(255)
lngRet = GetTempPath(Len(strTempPath), strTempPath)
TempPath = TrimNulls(strTempPath)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"TempPath"
Resume PROC_EXIT
End Property
Property Get UserName() As String
' Returns : The windows user name
' Source: Total VB SourceBook 6
'
Const cintStringLength As Integer = 100
Dim strUserName As String * cintStringLength
On Error GoTo PROC_ERR
GetUserName strUserName, cintStringLength
UserName = TrimNulls(strUserName)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"UserName"
Resume PROC_EXIT
End Property
Property Get WindowsDirectory() As String
' Returns : The Windows directory
' Source: Total VB SourceBook 6
Dim strWindowsDirectory As String * MAX_PATH
On Error GoTo PROC_ERR
GetWindowsDirectory strWindowsDirectory, MAX_PATH
WindowsDirectory = TrimNulls(strWindowsDirectory)
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"WindowsDirectory"
Resume PROC_EXIT
End Property
Property Get WindowsType() As EnumWindowsType
' Returns : The type of windows
' Source: Total VB SourceBook 6
Dim typVersion As OSVERSIONINFO
On Error GoTo PROC_ERR
typVersion.dwOSVersionInfoSize = Len(typVersion)
GetVersionEx typVersion
WindowsType = typVersion.dwPlatformId
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"WindowsType"
Resume PROC_EXIT
End Property
Public Sub GetWorkArea( _
intLeft As Integer, _
intTop As Integer, _
intWidth As Integer, _
intHeight As Integer)
' Comments : Returns the visible area of the desktop, minus the taskbar
' Parameters: intLeft - The left position, in pixels, of the work area
' intTop - The top position, in pixels, of the work area
' intWidth - The width, in pixels, of the work area
' intHeight - The height, in pixels, of the work area
' Returns : Nothing
' Source : Total VB SourceBook 6
'
Dim rectScreen As RECT
Dim lngResult As Long
On Error GoTo PROC_ERR
lngResult = SystemParametersInfo( _
SPI_GETWORKAREA, _
0&, _
ByVal VarPtr(rectScreen), _
0&)
intLeft = rectScreen.Left
intTop = rectScreen.Top
intWidth = rectScreen.Right - rectScreen.Left
intHeight = rectScreen.Bottom - rectScreen.Top
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"GetWorkArea"
Resume PROC_EXIT
End Sub
Private Function RegistryGetKeyValue( _
ByVal lngRootKey As Long, _
strKeyName As String, _
strValueName As String) _
As Variant
' Comments : Returns a value from the system registry
' Parameters: lngRootKey - root key value, must be one of the following
' strKeyName - The name of the key
' strValueName - The name of the value
' Returns : The data in the registry value
' Source : Total VB SourceBook 6
'
Dim lngRetVal As Long
Dim lngHKey As Long
Dim varValue As Variant
Dim strValueData As String
Dim abytValueData() As Byte
Dim lngValueData As Long
Dim lngValueType As Long
Dim lngDataSize As Long
On Error GoTo PROC_ERR
varValue = Empty
lngRetVal = RegOpenKeyEx(lngRootKey, strKeyName, 0&, mcregKeyQueryValue, _
lngHKey)
If mcregErrorNone = lngRetVal Then
lngRetVal = RegQueryValueExNULL(lngHKey, strValueName, 0&, lngValueType, _
0&, lngDataSize)
If mcregErrorNone = lngRetVal Then
Select Case lngValueType
' String type
Case mcregSZ:
If lngDataSize > 0 Then
strValueData = String(lngDataSize, 0)
lngRetVal = RegQueryValueExString(lngHKey, strValueName, 0&, _
lngValueType, strValueData, lngDataSize)
If InStr(strValueData, vbNullChar) > 0 Then
strValueData = Mid$(strValueData, 1, InStr(strValueData, _
vbNullChar) - 1)
End If
End If
If mcregErrorNone = lngRetVal Then
varValue = Left$(strValueData, lngDataSize)
Else
varValue = Empty
End If
' Long type
Case mcregDWord:
lngRetVal = RegQueryValueExLong(lngHKey, strValueName, 0&, _
lngValueType, lngValueData, lngDataSize)
If mcregErrorNone = lngRetVal Then
varValue = lngValueData
End If
' Binary type
Case mcregBinary
If lngDataSize > 0 Then
ReDim abytValueData(lngDataSize)
lngRetVal = RegQueryValueExBinary(lngHKey, strValueName, 0&, _
lngValueType, VarPtr(abytValueData(0)), lngDataSize)
End If
If mcregErrorNone = lngRetVal Then
varValue = abytValueData
Else
varValue = Empty
End If
Case Else
'No other data types supported
lngRetVal = -1
End Select
End If
RegCloseKey (lngHKey)
End If
'Return varValue
RegistryGetKeyValue = varValue
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryGetKeyValue"
Resume PROC_EXIT
End Function
Private Function TrimNulls(ByVal strIn As String) As String
' Comments : Returns the passed string terminated at the first null
' Parameters: strIn - Value to parse
' Returns : Parsed string
' Source : Total VB SourceBook 6
'
Dim intPos As Integer
On Error GoTo PROC_ERR
intPos = InStr(strIn, vbNullChar)
If intPos = 0 Then
' No nulls in the string, just return it as is
TrimNulls = strIn
Else
If intPos = 1 Then
' If the null character is at the first position, the
' entire string is a null string, so return a zero-length string
TrimNulls = ""
Else
' Not at the first position, so return the contents up
' to the occurrence of the null character
TrimNulls = Left$(strIn, intPos - 1)
End If
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"TrimNulls"
Resume PROC_EXIT
End Function
|
Regards
Shady
____________________________
I don't wanna die... but I ain't keen on livin' either
|
