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
Retrieve Windows Info in Visual Basic 6.0
Retrieve Windows Info in Visual Basic 6.0
2008-02-12T22:31:00-08:00
Bonitoo
Programming
|
Source Code
|