Retrieve Windows Info in Visual Basic 6.0

Need to know more on how to retrieve various windows system information using visual basic 6.0?

I've got this module from various internet location, thanks to Internet.
With this module:

Get the current user
Get the OSVersion
Get the Computer Name
Get the Display Information
Get the Drive Information, control panel,
etc...



Option Explicit

'Windows System Information Constants
Private Const SQL_SUCCESS As Long = 0
Private Const SQL_FETCH_NEXT = 1
Private Const SQL_FETCH_FIRST_SYSTEM = 32

Private Const SECS_PER_DAY As Long = 86000
Private Const MINS_PER_DAY As Long = 1400

'Enumerated Types
Public Enum ControlPanelTypes
cplSystem = 1
cplInternet = 2
cplModem = 3
cplSoftware = 4
cplHardware = 5
cplSounds = 6
cplNetwork = 7
cplMouse = 8
cplKeyboard = 9
cplDateTime = 10
cplRegional = 11
cplPassword = 12
cplDisplay = 13
End Enum

Public Enum DIR_TYPE
dirWINDOWS
dirSYSTEM
dirTEMP
End Enum

Public Enum DRIVE_TYPE
DRIVE_DOESNT_EXIST = 1
DRIVE_REMOVABLE = 2
DRIVE_FIXED = 3
DRIVE_REMOTE = 4
DRIVE_CDROM = 5
DRIVE_RAMDISK = 6
End Enum

Public Enum enStockIcons
IDI_APPLICATION = 32512&
IDI_ASTERISK = 32516&
IDI_EXCLAMATION = 32515&
IDI_HAND = 32513& 'This is the STOP icon
IDI_QUESTION = 32514&
End Enum

Public Enum OS_VERSION
OS_WINDOWS_UNKNOWN
OS_WINDOWS_3X
OS_WINDOWS_95
OS_WINDOWS_98
OS_WINDOWS_NT3X
OS_WINDOWS_NT40
OS_WINDOWS_2000
End Enum

Private Type OSVERSIONINFOEX
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
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

Public Enum ShutdownType
Logoff = 0
ByeBye = 1
Reboot = 2
End Enum

Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2

Private Const BITSPIXEL = 12
Private Const PLANES = 14

' API Declarations for the Locale Methods
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
'API Functions
Private Declare Function DrawIconApi Lib "user32" Alias "DrawIcon" (ByVal HDC As Long, ByVal x As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer 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 OSVERSIONINFOEX) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (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 GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpSFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function LoadIconApi Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SQLAllocEnv Lib "odbc32.dll" (phenv As Long) As Integer
Private Declare Function SQLDataSources Lib "odbc32.dll" (ByVal hEnv As Long, ByVal fDirection As Integer, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN As Integer, ByVal szDescription As String, ByVal cbDescriptionMax As Integer, pcbDescription As Integer) As Integer
Private Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal hEnv As Long) As Integer
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

Private pUdtOSVersion As OSVERSIONINFOEX
Private pUdtMemStatus As MEMORYSTATUS

Private plMajorVersion As Long
Private plMinorVersion As Long
Private plPlatformID As Long

Private psComputerName As String
Private plLastDllError As Long

'-----------------
'Public Properties
'-----------------
Public Property Get Name() As String
Dim sBuffer As String
Dim lAns As Long

plLastDllError = 0
sBuffer = Space$(255)
lAns = GetComputerName(sBuffer, 255)
If lAns <> 0 Then
'read from beginning of string to null-terminator
Name = Left$(sBuffer, InStr(sBuffer, Chr(0)) - 1)
Else
plLastDllError = Err.LastDllError
End If
End Property

Public Property Get CurrentUser() As String
Dim l As Long
Dim sUser As String

plLastDllError = 0
sUser = Space(255)
l = GetUserName(sUser, 255)
'strip null terminator
If l <> 0 Then
CurrentUser = Left(sUser, InStr(sUser, Chr(0)) - 1)
Else
plLastDllError = Err.LastDllError
End If
End Property

Public Property Get MaxScreenColors() As Double
'Returns the maximum number of colors supported
'by the system - e.g., 256, 16,777,216
Dim lngBits As Long
Dim lngPlanes As Long
Dim lwndHandle As Long
Dim dblAns As Double
plLastDllError = 0
lwndHandle = Form1.HDC
'bits per pixel
lngBits = GetDeviceCaps(lwndHandle, BITSPIXEL)
'number of color planes
lngPlanes = GetDeviceCaps(lwndHandle, PLANES)
'maximum colors available
MaxScreenColors = (2 ^ (lngBits * lngPlanes))
plLastDllError = Err.LastDllError
End Property

Public Property Get OSVersion() As OS_VERSION
On Error GoTo ErrorHandler

plLastDllError = 0
Select Case plMajorVersion
Case 5: OSVersion = OS_WINDOWS_2000 'UNTESTED
Case 4
If plPlatformID = VER_PLATFORM_WIN32_NT Then
OSVersion = OS_WINDOWS_NT40
Else
OSVersion = IIf(plMinorVersion = 0, OS_WINDOWS_95, OS_WINDOWS_98)
End If
Case 3
If plPlatformID = VER_PLATFORM_WIN32s Then
OSVersion = OS_WINDOWS_3X
ElseIf plPlatformID = VER_PLATFORM_WIN32_NT Then
OSVersion = OS_WINDOWS_NT40
End If
Case Else: OSVersion = OS_WINDOWS_UNKNOWN
End Select
Exit Property
ErrorHandler:
OSVersion = OS_WINDOWS_UNKNOWN
plLastDllError = Err.LastDllError
End Property

Public Property Get ScreenPixelWidth() As Integer
plLastDllError = 0
ScreenPixelWidth = Screen.Width \ Screen.TwipsPerPixelX
End Property

Public Property Get ScreenPixelHeight() As Integer
plLastDllError = 0
ScreenPixelHeight = Screen.Height \ Screen.TwipsPerPixelY
End Property

Public Property Get ScreenResolution() As String
plLastDllError = 0
ScreenResolution = ScreenPixelWidth & "x" & ScreenPixelHeight
End Property

Public Property Get SystemErrorCode() As Long
SystemErrorCode = plLastDllError
End Property

Public Property Get SoundCard() As Boolean
SoundCard = waveOutGetNumDevs > 0
End Property
'----------------
'Public Functions
'----------------
Public Function AboutBox(Optional hWndA As Long = -1, Optional Copyright As String, Optional ProductInfo As String, Optional Icon As Long = 0)
If Len(Copyright) = 0 Then Copyright = Common.Version() & "#" & App.ProductName
If Len(ProductInfo) = 0 Then
If Len(App.LegalTrademarks) > 0 And Len(App.CompanyName) > 0 Then
ProductInfo = App.LegalTrademarks
ProductInfo = ProductInfo & " are legal trademarks of "
ProductInfo = ProductInfo & App.CompanyName
Else
ProductInfo = ProjectName
ProductInfo = ProductInfo & " is a legal trademark of "
ProductInfo = ProductInfo & IIf(Len(App.CompanyName) > 0, App.CompanyName, "FailSafe Systems")
End If
End If
Call ShellAbout(hWndA, Copyright, ProductInfo, Icon)
End Function

Public Function APIFunctionPresent(ByVal FunctionName As String, ByVal DLLName As String) As Boolean
'USAGE: Dim bAvail as boolean
' bAvail = APIFunctionPresent("GetDiskFreeSpaceExA", "kernel32")
Dim lHandle As Long
Dim lAddr As Long
lHandle = LoadLibrary(DLLName)
If lHandle <> 0 Then
lAddr = GetProcAddress(lHandle, FunctionName)
FreeLibrary lHandle
End If
APIFunctionPresent = (lAddr <> 0)
End Function

Public Sub CascadeWindows()
' TODO:
' Dim objShell As New Shell32.Shell
' objShell.CascadeWindows
' Set objShell = Nothing
End Sub

Public Function ControlPanel(Setting As ControlPanelTypes) As Long
Dim lPanel As String
Select Case Setting
Case cplSoftware: lPanel = "appwiz.cpl,,1"
Case cplHardware: lPanel = "sysdm.cpl @1"
Case cplInternet: lPanel = "inetcpl.cpl,,0"
Case cplKeyboard: lPanel = "main.cpl @1"
Case cplModem: lPanel = "modem.cpl"
Case cplMouse: lPanel = "main.cpl @0"
Case cplNetwork: lPanel = "netcpl.cpl"
Case cplSounds: lPanel = "mmsys.cpl @1"
Case cplSystem: lPanel = "sysdm.cpl,,0"
Case cplDisplay: lPanel = "desk.cpl,,0"
Case cplPassword: lPanel = "password.cpl"
Case cplRegional: lPanel = "intl.cpl,,0"
Case cplDateTime: lPanel = "timedate.cpl"
End Select
If Len(lPanel) > 0 Then ControlPanel = Shell("rundll32.exe shell32.dll,Control_RunDLL " & lPanel, 5)
plLastDllError = Err.LastDllError
End Function

Public Function Directory(WhichDir As DIR_TYPE) As String
Dim Temp As String
Dim Ret As Long
Const MAX_LENGTH = 255

Temp = String$(MAX_LENGTH, 0)
Select Case WhichDir
Case dirWINDOWS: Ret = GetWindowsDirectory(Temp, MAX_LENGTH)
Case dirSYSTEM: Ret = GetSystemDirectory(Temp, MAX_LENGTH)
Case dirTEMP: Ret = GetTempPath(Len(Temp), Temp)
Case Else: Ret = 0: Temp = ""
End Select
Directory = PathCheck(Left$(Temp, Ret))
End Function

Public Function DriveMBFree(Optional Drive As String = "C:\") As Double
'some time in the future disk may be to large to calculate
'like this so resume next on any errors
On Error Resume Next

Dim lAns As Long
Dim lSectorsPerCluster As Long
Dim lBytesPerSector As Long

Dim lFreeClusters As Long
Dim lTotalClusters As Long
Dim lBytesPerCluster As Long
Dim lFreeBytes As Double

'fix bad parameter values
If Len(Drive) = 1 Then Drive = Drive & ":\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"

lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
lBytesPerCluster = lSectorsPerCluster * lBytesPerSector

DriveMBFree = ((lBytesPerCluster / 1024) / 1024) * lFreeClusters
DriveMBFree = Format(DriveMBFree, "###,###,##0.00")
End Function

Public Function DriveMBSize(Optional Drive As String = "C:\") As Double
'some time in the future disk may be to large to calculate
'like this so resume next on any errors
On Error Resume Next

Dim lAns As Long
Dim lSectorsPerCluster As Long
Dim lBytesPerSector As Long

Dim lFreeClusters As Long
Dim lTotalClusters As Long
Dim lBytesPerCluster As Long
Dim lTotalBytes As Double

'fix bad parameter values
If Len(Drive) = 1 Then Drive = Drive & ":\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"

lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
lBytesPerCluster = lSectorsPerCluster * lBytesPerSector

DriveMBSize = ((lBytesPerCluster / 1024) / 1024) * lTotalClusters
DriveMBSize = Format(DriveMBSize, "###,###,##0.00")
End Function

Public Function DriveName(Optional Drive As String = "C:\")
Dim sBuffer As String

plLastDllError = 0
sBuffer = Space$(255)
'fix bad parameter values
If Len(Drive) = 1 Then Drive = Drive & ":\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"
If GetVolumeInformation(Drive, sBuffer, Len(sBuffer), 0, 0, 0, Space$(255), 255) = 0 Then
plLastDllError = Err.LastDllError
Else
DriveName = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)
End If
End Function

Public Function DriveType(Drive As String) As DRIVE_TYPE
'fix bad parameter values
DriveType = DRIVE_DOESNT_EXIST
plLastDllError = 0
Drive = IIf(Len(Drive) = 1, Drive & ":", Drive)
If Len(Drive) = 1 Then Drive = Drive & ":\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" Then Drive = Drive & "\"
Drive = PathCheck(Drive)
DriveType = GetDriveType(Drive)
plLastDllError = Err.LastDllError
End Function

Public Sub DSNs(DSNArray() As String)
'POPULATES DSNARRAY WITH ALL DSNs installed on the system,
'in the form of "DSN | DRIVER"
'USAGE:
'Dim asDSNArray() As String
'Dim iCtr As Integer
'SystemDSNs asDSNArray
'For iCtr = 0 To UBound(asDSNArray)
' Debug.Print asDSNArray(iCtr)
'Next
Dim iRet As Integer
Dim sDSN As String
Dim sDriver As String
Dim iDSNLen As Integer
Dim iDriverLen As Integer
ReDim DSNArray(0) As String
Dim lEnvHandle As Long

iRet = SQLAllocEnv(lEnvHandle)
sDSN = Space(1024)
sDriver = Space(1024)
iRet = SQLDataSources(lEnvHandle, SQL_FETCH_FIRST_SYSTEM, sDSN, 1024, iDSNLen, sDriver, 1024, iDriverLen)

If iRet = SQL_SUCCESS Then
sDSN = Mid(sDSN, 1, iDSNLen)
sDriver = Mid(sDriver, 1, iDriverLen)
DSNArray(0) = sDSN & " | " & sDriver
Do Until iRet <> SQL_SUCCESS
sDSN = Space(1024)
sDriver = Space(1024)
iRet = SQLDataSources(lEnvHandle, SQL_FETCH_NEXT, sDSN, 1024, iDSNLen, sDriver, 1024, iDriverLen)
If Trim(sDSN) <> "" Then
sDSN = Mid(sDSN, 1, iDSNLen)
sDriver = Mid(sDriver, 1, iDriverLen)
ReDim Preserve DSNArray(UBound(DSNArray) + 1)
DSNArray(UBound(DSNArray)) = sDSN & " | " & sDriver
End If
Loop
End If
iRet = SQLFreeEnv(lEnvHandle)
End Sub

Public Function IsConnectedToInternet(Optional ConnectMode As Integer) As Boolean
Dim flags As Long
IsConnectedToInternet = InternetGetConnectedState(flags, 0) ' this ASPI function does it all
ConnectMode = flags ' return the flag through the optional argument
End Function

Public Function MemoryAvailable() As Double
'Return Value in Megabytes
MemoryAvailable = MemoryAvailablePhysical + MemoryPageFile
End Function

Public Function MemoryAvailablePhysical() As Double
'Return Value in Megabytes
Dim dblAns As Double
plLastDllError = 0
GlobalMemoryStatus pUdtMemStatus
dblAns = pUdtMemStatus.dwAvailPhys
MemoryAvailablePhysical = BytesToMegabytes(dblAns)
plLastDllError = Err.LastDllError
End Function

Public Function MemoryInTotal() As Double
'Return Value in Megabytes
MemoryInTotal = MemoryPageFileSize + MemoryTotalPhysical
End Function

Public Function MemoryPageFile() As Double
'Return Value in Megabytes
Dim dblAns As Double

plLastDllError = 0
GlobalMemoryStatus pUdtMemStatus
dblAns = pUdtMemStatus.dwAvailPageFile
MemoryPageFile = BytesToMegabytes(dblAns)
plLastDllError = Err.LastDllError
End Function

Public Function MemoryPageFileSize() As Double
'Return Value in Megabytes
Dim dblAns As Double

plLastDllError = 0
GlobalMemoryStatus pUdtMemStatus
dblAns = pUdtMemStatus.dwTotalPageFile
MemoryPageFileSize = BytesToMegabytes(dblAns)
plLastDllError = Err.LastDllError
End Function

Public Function MemoryPercentFree() As Double
MemoryPercentFree = Format(MemoryAvailable / MemoryInTotal * 100, "0#")
End Function

Public Function MemoryTotalPhysical() As Double
'Return Value in Megabytes
Dim dblAns As Double
plLastDllError = 0
GlobalMemoryStatus pUdtMemStatus
dblAns = pUdtMemStatus.dwTotalPhys
MemoryTotalPhysical = BytesToMegabytes(dblAns)
plLastDllError = Err.LastDllError
End Function

Public Function Running(Optional InSeconds As Boolean = False) As Double
Running = SECS_PER_DAY * (GetTickCount / 1000 / 60 / 60 / 24)
Running = IIf(InSeconds, Round(Running, 2), Round(Running / 3600, 2))
End Function

Public Function ShutDown(ExitType As ShutdownType) As Long
ShutDown = ExitWindowsEx(ExitType, 0&)
End Function

Public Function Started() As Date
Dim dTicks As Double
'Store the number of days the systems has been running
dTicks = GetTickCount / 1000 / 60 / 60 / 24
Started = Now() - dTicks
End Function

'-----------------
'Private Functions
'-----------------
Private Function BytesToMegabytes(bytes As Double) As Double
Dim dblAns As Double
dblAns = (bytes / 1024) / 1024
BytesToMegabytes = Format(dblAns, "###,###,##0.00")
End Function

Private Function FreeBytesOnDisk(Drive As String) As Long
On Error Resume Next
plLastDllError = 0

Dim lAns As Long
Dim lSectorsPerCluster As Long
Dim lBytesPerSector As Long

Dim lFreeClusters As Long
Dim lTotalClusters As Long
Dim lBytesPerCluster As Long
Dim lFreeBytes As Double


lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
lBytesPerCluster = lSectorsPerCluster * lBytesPerSector
lFreeBytes = lBytesPerCluster * lFreeClusters
FreeBytesOnDisk = lFreeBytes
plLastDllError = Err.LastDllError
End Function

Private Function PathCheck(ByVal PathName As String, Optional AltDelimiter As String = "") As String
If Len(PathName) = 0 Then Exit Function
Dim Delimiter As String
Delimiter = IIf(InStr(PathName, "/"), "/", "\")
PathCheck = IIf(Right$(PathName, 1) = Delimiter, PathName, PathName & Delimiter)
PathCheck = IIf(Len(AltDelimiter) = 0, PathCheck, Replace(PathCheck, Delimiter, AltDelimiter))
End Function

Private Function TotalBytesOnDisk(Drive As String) As Double
On Error Resume Next
plLastDllError = 0
Dim lAns As Long
Dim lSectorsPerCluster As Long
Dim lBytesPerSector As Long

Dim lFreeClusters As Long
Dim lTotalClusters As Long
Dim lBytesPerCluster As Long
Dim lTotalBytes As Double

lAns = GetDiskFreeSpace(Drive, lSectorsPerCluster, lBytesPerSector, lFreeClusters, lTotalClusters)
lBytesPerCluster = lSectorsPerCluster * lBytesPerSector
'dblAns = (Bytes / 1024) / 1024
TotalBytesOnDisk = lBytesPerCluster * lTotalClusters
If TotalBytesOnDisk = 0 Then
TotalBytesOnDisk = ((lBytesPerCluster / 1024) / 1024) * lTotalClusters
End If
plLastDllError = Err.LastDllError
End Function

Public Function LoadSystemIcon(ByVal StockIcon As enStockIcons) As Long
On Error Resume Next
LoadSystemIcon = LoadIconApi(0, StockIcon)
End Function


Public Sub DrawIcon(ByVal HDC As Long, ByVal xPos As Long, ByVal yPos As Long, ByVal Icon As Long)
Dim lRet As Long
lRet = DrawIconApi(HDC, xPos, yPos, Icon)
If (Err.LastDllError > 0) Or (lRet = 0) Then Debug.Print "DrawIcon failed"
End Sub
'use:

'---------------------
' Class Initialization
'---------------------
Private Sub Class_Initialize()
pUdtOSVersion.dwOSVersionInfoSize = Len(pUdtOSVersion)
GetVersionEx pUdtOSVersion
plMajorVersion = pUdtOSVersion.dwMajorVersion
plMinorVersion = pUdtOSVersion.dwMinorVersion
plPlatformID = pUdtOSVersion.dwPlatformId
End Sub

Private Sub Class_Terminate()
'
End Sub



Related Posts by Categories



Widget by Hoctro

Enter your email address:

Delivered by FeedBurner

Followers



Source Code