J
J Holtendehouzer
Is there a way to determine the width of the screen (as opposed to the width
of the form)?
Thanks!
of the form)?
Thanks!
You are using an out of date browser. It may not display this or other websites correctly.
You should upgrade or use an alternative browser.
You should upgrade or use an alternative browser.
G
Guest
Hi!
You'll find what you need hereafter. Unfortunately I cannot remember where I
downloaded this module, however I did not wrote it.
Attribute VB_Name = "SysInfo_Module"
Option Compare Database
Option Explicit
Type ULARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Declare Function api_GetDiskFreeSpace Lib "kernel32" Alias
"GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long,
lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Private Declare Function api_GetDiskFreeSpaceEx Lib "kernel32" Alias
"GetDiskFreeSpaceExA" _
(ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As
Currency, _
lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency)
As Long
Private Declare Function api_GetDriveType Lib "kernel32" Alias
"GetDriveTypeA" _
(ByVal lpRootPathName As String) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As
SYSTEM_INFO)
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpOSInfo As OSVERSIONINFO) As Boolean
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As
MEMORYSTATUS)
Private Declare Function api_GetUserName Lib "advapi32.dll" Alias
"GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function api_GetComputerName Lib "kernel32" Alias
"GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function api_CreateIC Lib "GDI32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput
As Any, _
ByVal lpInitData As Any) As Long
Private Declare Function api_DeleteDC Lib "GDI32" Alias "DeleteDC" (ByVal
hdc As Long) As Long
Private Declare Function api_GetDeviceCaps Lib "GDI32" Alias "GetDeviceCaps"
_
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function api_SetErrorMode Lib "kernel32" Alias
"SetErrorMode" _
(ByVal fuErrorMode As Long) As Long
'Declares for Version Verification
'
Private Declare Function ac_GetFileVersionInfoSize Lib "Version.dll" Alias
"GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function ac_GetFileVersionInfo Lib "Version.dll" Alias
"GetFileVersionInfoA" _
(ByVal lptstrFilename As String, ByVal dwHandle As Long, ByVal dwLen As
Long, lpData As Any) As Long
Private Declare Function ac_VerQueryValue Lib "Version.dll" Alias
"VerQueryValueA" _
(pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As
Long) As Long
Private Declare Sub ac_MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, ByVal Source As Long, ByVal length As Long)
Const Jet_FILENAME = "MSJT3032.DLL"
Const Jet35_FILE = "msjet35.dll"
Const SEM_FAILCRITICALERRORS = &H1
' Type returned by VER.DLL GetFileVersionInfo
Private Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersionl As Integer ' e.g. = &h0000 = 0
dwStrucVersionh As Integer ' e.g. = &h0042 = .42
dwFileVersionMSl As Integer ' e.g. = &h0003 = 3
dwFileVersionMSh As Integer ' e.g. = &h0075 = .75
dwFileVersionLSl As Integer ' e.g. = &h0000 = 0
dwFileVersionLSh As Integer ' e.g. = &h0031 = .31
dwProductVersionMSl As Integer ' e.g. = &h0003 = 3
dwProductVersionMSh As Integer ' e.g. = &h0010 = .1
dwProductVersionLSl As Integer ' e.g. = &h0000 = 0
dwProductVersionLSh As Integer ' e.g. = &h0031 = .31
dwFileFlagsMask As Long ' = &h3F for version "0.42"
dwFileFlags As Long ' e.g. VFF_DEBUG Or VFF_PRERELEASE
dwFileOS As Long ' e.g. VOS_DOS_WINDOWS16
dwFileType As Long ' e.g. VFT_DRIVER
dwFileSubtype As Long ' e.g. VFT2_DRV_KEYBOARD
dwFileDateMS As Long ' e.g. 0
dwFileDateLS As Long ' e.g. 0
End Type
Type fBuffer
Item As String * 1024
End Type
Private Type SYSTEM_INFO
dwOemID As Long
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
dwReserved As Long
End Type
Const VER_PLATFORM_WIN32s = 0
Const VER_PLATFORM_WIN32_WINDOWS = 1 ' Windows 95
Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
strReserved 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 Function atGetSysStatus(intStatus As Integer) As Variant
'
'Purpose: Retrieve system status information
'
'Accepts: intStatus: which piece of information to retrieve
' 1: The number of CPUs in the system
' 2: The type of CPUs in the system
'
'Returns: The requested information
On Error Resume Next
Dim SI As SYSTEM_INFO
Dim CPUType$
GetSystemInfo SI
Select Case intStatus
Case 1
atGetSysStatus = SI.dwNumberOrfProcessors
Case 2
CPUType = SI.dwProcessorType
If CPUType = "586" Then
atGetSysStatus = "Pentium"
Else
atGetSysStatus = CPUType
End If
Case Else
atGetSysStatus = 0
End Select
End Function
Function atDiskFreeSpace(Drive As String) As String
'
'Purpose: Return Free Space
'
'Accepts: A Drive letter
'
'Returns: Disk space available
'
On Error GoTo Err_DF
Dim wResult
Dim TotalSpace As Long
Dim TotalSpaceMB As Single
Dim FreeSpace As Long
Dim FreeSpaceMB As Single
Dim PercentFree As Single
Dim Path As String
Dim Sectors As Long
Dim Bytes As Long
Dim FClusters As Long
Dim TClusters As Long
Dim ErrorMode&
If IsNull(Drive) Then Exit Function
'
'Set the error mode for the system so that "system errors" are ignored
'and we let Access handle the errors, capture the return value so that
'the error mode can be reset to its initial setting upon exit from the
'function
'
ErrorMode = api_SetErrorMode(SEM_FAILCRITICALERRORS)
wResult = Dir(Drive & ":\*.*")
Path = Drive & ":\" & Chr$(0)
wResult = api_GetDiskFreeSpace(Path, Sectors, Bytes, FClusters,
TClusters)
TotalSpace = Sectors * Bytes * TClusters
TotalSpaceMB = (TotalSpace / 1024) / 1024
FreeSpace = Sectors * Bytes * FClusters
FreeSpaceMB = (FreeSpace / 1024) / 1024
PercentFree = (FreeSpace / TotalSpace) * 100
If TotalSpace = -1 Then
atDiskFreeSpace = "Drive Not Available"
Else
If FreeSpaceMB < 1000 And TotalSpaceMB < 1000 Then
atDiskFreeSpace = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% of " & Format$(TotalSpaceMB, "0.##") & "
MB"
ElseIf FreeSpaceMB < 1000 And TotalSpaceMB > 1000 Then
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpace = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% of " & Format$(TotalSpaceMB, "0.##") & "
GB"
Else
FreeSpaceMB = FreeSpaceMB / 1024
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpace = Format$(FreeSpaceMB, "###0.##") & " GB: " &
Format$(PercentFree, "0.##") & "% of " & Format$(TotalSpaceMB, "0.##") & "
GB"
End If
End If
ErrorMode = api_SetErrorMode(ErrorMode)
Exit_DF:
Exit Function
Err_DF:
If Err = 71 Then
MsgBox "There is no disc in Drive " & Drive & ":, the drive door is
not closed, or the current disc has not been formatted.", 16, "System
Information"
ElseIf Err = 68 Then
atDiskFreeSpace = "Drive Not Available"
Resume Exit_DF
ElseIf Err = 75 Or 76 Then
MsgBox "Drive " & Drive & ": is not accessable. If the Drive is a
CDROM then make sure it is turned on and/or a disk is in the Drive.", 16,
"System Information "
ElseIf Err = 3043 Then
MsgBox "The Network or Disc Drive " & Drive & " is unavailable or
has produced an error", 48, "System Information"
Else
MsgBox "Error " & Err.Description, 48, "System Information"
End If
ErrorMode = api_SetErrorMode(ErrorMode)
atDiskFreeSpace = "Drive Not Available"
Resume Exit_DF
End Function
Function atDiskFreeSpaceEx(Drive As String) As String
'
'Purpose: Return Free Space on Drives
'
'Accepts: A Drive letter
'
'Returns: Disk space available
'
On Error GoTo Err_DF
Dim wResult
Dim TotalSpace As Long
Dim TotalSpaceMB As Double
Dim FreeSpace As Long
Dim FreeSpaceMB As Double
Dim PercentFree As Single
Dim Path As String
Dim FreeBytesCaller As Currency
Dim TotalBytes As Currency
Dim TotalFreeBytes As Currency
Dim Sectors As Long
Dim Bytes As Long
Dim FClusters As Long
Dim TClusters As Long
Dim ErrorMode&
If IsNull(Drive) Then Exit Function
'
'Set the error mode for the system so that "system errors" are ignored
'and we let Access handle the errors, capture the return value so that
'the error mode can be reset to its initial setting upon exit from the
'function
'
ErrorMode = api_SetErrorMode(SEM_FAILCRITICALERRORS)
wResult = Dir(Drive & ":\*.*")
Path = Drive & ":\" & Chr$(0)
On Error Resume Next
'
'Only supported on Win95 OSR2 and above and NT 4 and above
'
wResult = api_GetDiskFreeSpaceEx(Path, FreeBytesCaller, TotalBytes,
TotalFreeBytes)
If Err = 0 Then
TotalSpaceMB = ((TotalBytes * 10000) / 1024) / 1024
FreeSpaceMB = ((FreeBytesCaller * 10000) / 1024) / 1024
Else
'
'Win95 OSR1
'
wResult = api_GetDiskFreeSpace(Path, Sectors, Bytes, FClusters,
TClusters)
TotalSpace = Sectors * Bytes * TClusters
TotalSpaceMB = (TotalSpace / 1024) / 1024
FreeSpace = Sectors * Bytes * FClusters
FreeSpaceMB = (FreeSpace / 1024) / 1024
End If
On Error GoTo Err_DF
PercentFree = (FreeSpaceMB / TotalSpaceMB) * 100
If TotalSpaceMB = -1 Then
atDiskFreeSpaceEx = "Drive Not Available"
Else
If FreeSpaceMB < 1000 And TotalSpaceMB < 1000 Then
atDiskFreeSpaceEx = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% de " & Format$(TotalSpaceMB, "0.##") & "
MB"
ElseIf FreeSpaceMB < 1000 And TotalSpaceMB > 1000 Then
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpaceEx = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% de " & Format$(TotalSpaceMB, "0.##") & "
GB"
Else
FreeSpaceMB = FreeSpaceMB / 1024
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpaceEx = Format$(FreeSpaceMB, "###0.##") & " GB: " &
Format$(PercentFree, "0.##") & "% de " & Format$(TotalSpaceMB, "0.##") & "
GB"
End If
End If
ErrorMode = api_SetErrorMode(ErrorMode)
Exit_DF:
Exit Function
Err_DF:
If Err = 71 Then
MsgBox "There is no disc in Drive " & Drive & ":, the drive door is
not closed, or the current disc has not been formatted.", 16, "System
Information"
ElseIf Err = 68 Then
atDiskFreeSpaceEx = "Drive Not Available"
Resume Exit_DF
ElseIf Err = 75 Or 76 Then
MsgBox "Drive " & Drive & ": is not accessable. If the Drive is a
CDROM then make sure it is turned on and/or a disk is in the Drive.", 16,
"System Information "
ElseIf Err = 3043 Then
MsgBox "The Network or Disc Drive " & Drive & " is unavailable or
has produced an error", 48, "System Information"
Else
MsgBox "Error " & Err.Description, 48, "System Information"
End If
ErrorMode = api_SetErrorMode(ErrorMode)
atDiskFreeSpaceEx = "Drive Not Available"
Resume Exit_DF
End Function
Public Function atGetColourCap() As String
'
'Purpose: Get the colour depth setting for the monitor
'
'Accepts: Nothing, calls GetDeviceCaps for the Display
'
'Returns: String Value base on the number of Bits and color
' Planes
'
On Error GoTo Err_Colour
Dim Planes As Integer
Dim Bits As Integer
Planes = atGetdevcaps(14)
Bits = atGetdevcaps(12)
If Planes = 1 Then
Select Case Bits
Case 8
atGetColourCap = "256"
Case 15
atGetColourCap = "32K"
Case 16
atGetColourCap = "64K"
Case 24
atGetColourCap = "16 Mil"
Case 32
atGetColourCap = "True"
End Select
ElseIf Planes = 4 Then
atGetColourCap = 16
Else
atGetColourCap = "Unk"
End If
Exit_Colour:
Exit Function
Err_Colour:
atGetColourCap = "Unk"
Resume Exit_Colour
End Function
Public Function atGetdevcaps%(ByVal intCapability%)
'
' Purpose: Returns information on the capabilities of
' a given device. Which device is determined
' by the arguments to api_CreateIC. Which
' capability is determined by the intCapability
' argument which is one of the constants
' defined for the GetDeviceCaps Windows API
' function.
'
' Arguments: intCapability - index of capability to check
' see win32api.txt for list of values
'
' Returns: Results of call to GetDeviceCaps
'
On Error GoTo getdevcapsError
'LogPixels X = 88 for capability
'LogPixels Y = 90 for capability
Dim hdc& 'handle for the device context
'Specify the device -- use "DISPLAY' to check screen capabilities
'
Const DRIVER_NAME = "DISPLAY"
Const DEVICE_NAME = 0&
Const OUTPUT_DEVICE = 0&
Const LPDEVMODE = 0&
'Get a handle to a device context (hDC)
'
hdc = api_CreateIC(DRIVER_NAME, DEVICE_NAME, OUTPUT_DEVICE, LPDEVMODE)
If hdc Then
'If a valid hDC was returned, call GetDeviceCaps and
'then release the DC
'
atGetdevcaps = api_GetDeviceCaps(hdc, intCapability)
hdc = api_DeleteDC(hdc)
End If
getdevcapsExit:
Exit Function
getdevcapsError:
MsgBox "Error: " & Err.Description, 48, "System Information"
Resume getdevcapsExit
End Function
Function atGetjetver() As String
'
'Purpose: Returns Version information on Jet DB Engine
' Based on the Version of Access Used
'
Dim Buffer As fBuffer
Dim VInfo As VS_FIXEDFILEINFO
Dim stBuf() As Byte
Dim lSize As Long
Dim stUnused As Long
Dim ErrCode As Long
Dim VerNum As Variant
Dim lVerPointer As Long
Dim lVerbufferLen As Long
Dim Jet$
If SysCmd(acSysCmdAccessVer) < 8 Then
Jet = Jet_FILENAME
Else
Jet = Jet35_FILE
End If
lSize = ac_GetFileVersionInfoSize(Jet, stUnused)
ReDim stBuf(lSize)
ErrCode = ac_GetFileVersionInfo(Jet, 0&, lSize, stBuf(0))
ErrCode = ac_VerQueryValue(stBuf(0), "\", lVerPointer, lVerbufferLen)
If ErrCode <> 0 Then
ac_MoveMemory VInfo, lVerPointer, Len(VInfo)
VerNum = Format$(VInfo.dwFileVersionMSh) & "." & _
Format$(VInfo.dwFileVersionMSl) & "." & _
Format$(VInfo.dwFileVersionLSh) & "." & _
Format$(VInfo.dwFileVersionLSl)
End If
atGetjetver = VerNum
End Function
Function atWinver(intOSInfo%) As Variant
'
'Purpose: Retrieve operating system information
'
'Accepts: intOSInfo: which piece of information to retrieve
' 0: Major Version
' 1: Minor version
' 2: Platform ID
'
' Returns: OS supplied Information
'
Dim OSInfo As OSVERSIONINFO
Dim dwReturn&
Const PLAT_WINDOWS = 1
Const PLAT_WIN_NT = 2
'Set the size equal to length of structure
'
OSInfo.dwOSVersionInfoSize = Len(OSInfo)
If GetVersionEx(OSInfo) Then
Select Case intOSInfo
Case 0
atWinver = OSInfo.dwMajorVersion
Case 1
atWinver = OSInfo.dwMinorVersion
Case 2
dwReturn = OSInfo.dwPlatformId
If dwReturn = PLAT_WINDOWS Then
atWinver = "Windows"
Else
atWinver = "Windows NT"
End If
Case 3
If OSInfo.dwPlatformId = PLAT_WINDOWS Then
atWinver = OSInfo.dwBuildNumber And &HFFF
Else
atWinver = OSInfo.dwBuildNumber
End If
End Select
Else
atWinver = 0
End If
End Function
Public Function atGetMem(intInfoItem As Integer) As Variant
'
'Purpose: Retrieve system memory use information
'
'Accepts: intInfoItem: Memory Info to retrieve
' 1: Total physical memory in bytes
' 2: Available physical memory in bytes
'
'Returns: The current memory use information
'
On Error Resume Next
Dim MemStat As MEMORYSTATUS
MemStat.dwLength = Len(MemStat)
Call GlobalMemoryStatus(MemStat)
Select Case intInfoItem
Case 1
atGetMem = MemStat.dwTotalPhys
Case 2
atGetMem = MemStat.dwAvailPhys
Case 3
atGetMem = MemStat.dwTotalVirtual
Case 4
atGetMem = MemStat.dwAvailVirtual
Case 5
atGetMem = MemStat.dwTotalPageFile
Case 6
atGetMem = MemStat.dwAvailPageFile
Case 7
atGetMem = MemStat.dwMemoryLoad
Case Else
atGetMem = 0
End Select
End Function
Public Function atDriveType(Drive As String) As Integer
'
'Purpose: Gets a integer value representing the drive type
'
'Accepts: A drive letter
'Returns: The drive type; used by after update of drive combo
' to change the drive picture
'
On Error GoTo Err_DT
Dim wResult As Long
Dim Path As String
Path = Drive & ":\" & Chr$(0)
wResult = api_GetDriveType(Path)
atDriveType = wResult
Exit Function
Err_DT:
atDriveType = 0
Exit Function
End Function
Public Function atCNames(UOrC As Integer) As String
'
'Purpose: Returns the User LogOn Name or ComputerName
'
'Accepts: UorC; 1=User, anything else = computer
'
'Returns: The Windows Networking name of the user or computer
'
On Error Resume Next
Dim NBuffer As String
Dim Buffsize As Long
Dim Wok As Long
Buffsize = 256
NBuffer = Space$(Buffsize)
If UOrC = 1 Then
Wok = api_GetUserName(NBuffer, Buffsize)
atCNames = Trim$(NBuffer)
Else
Wok = api_GetComputerName(NBuffer, Buffsize)
atCNames = Trim$(NBuffer)
End If
End Function
You'll find what you need hereafter. Unfortunately I cannot remember where I
downloaded this module, however I did not wrote it.
Attribute VB_Name = "SysInfo_Module"
Option Compare Database
Option Explicit
Type ULARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Declare Function api_GetDiskFreeSpace Lib "kernel32" Alias
"GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long,
lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Private Declare Function api_GetDiskFreeSpaceEx Lib "kernel32" Alias
"GetDiskFreeSpaceExA" _
(ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As
Currency, _
lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency)
As Long
Private Declare Function api_GetDriveType Lib "kernel32" Alias
"GetDriveTypeA" _
(ByVal lpRootPathName As String) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As
SYSTEM_INFO)
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpOSInfo As OSVERSIONINFO) As Boolean
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As
MEMORYSTATUS)
Private Declare Function api_GetUserName Lib "advapi32.dll" Alias
"GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function api_GetComputerName Lib "kernel32" Alias
"GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function api_CreateIC Lib "GDI32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput
As Any, _
ByVal lpInitData As Any) As Long
Private Declare Function api_DeleteDC Lib "GDI32" Alias "DeleteDC" (ByVal
hdc As Long) As Long
Private Declare Function api_GetDeviceCaps Lib "GDI32" Alias "GetDeviceCaps"
_
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function api_SetErrorMode Lib "kernel32" Alias
"SetErrorMode" _
(ByVal fuErrorMode As Long) As Long
'Declares for Version Verification
'
Private Declare Function ac_GetFileVersionInfoSize Lib "Version.dll" Alias
"GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function ac_GetFileVersionInfo Lib "Version.dll" Alias
"GetFileVersionInfoA" _
(ByVal lptstrFilename As String, ByVal dwHandle As Long, ByVal dwLen As
Long, lpData As Any) As Long
Private Declare Function ac_VerQueryValue Lib "Version.dll" Alias
"VerQueryValueA" _
(pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As
Long) As Long
Private Declare Sub ac_MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, ByVal Source As Long, ByVal length As Long)
Const Jet_FILENAME = "MSJT3032.DLL"
Const Jet35_FILE = "msjet35.dll"
Const SEM_FAILCRITICALERRORS = &H1
' Type returned by VER.DLL GetFileVersionInfo
Private Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersionl As Integer ' e.g. = &h0000 = 0
dwStrucVersionh As Integer ' e.g. = &h0042 = .42
dwFileVersionMSl As Integer ' e.g. = &h0003 = 3
dwFileVersionMSh As Integer ' e.g. = &h0075 = .75
dwFileVersionLSl As Integer ' e.g. = &h0000 = 0
dwFileVersionLSh As Integer ' e.g. = &h0031 = .31
dwProductVersionMSl As Integer ' e.g. = &h0003 = 3
dwProductVersionMSh As Integer ' e.g. = &h0010 = .1
dwProductVersionLSl As Integer ' e.g. = &h0000 = 0
dwProductVersionLSh As Integer ' e.g. = &h0031 = .31
dwFileFlagsMask As Long ' = &h3F for version "0.42"
dwFileFlags As Long ' e.g. VFF_DEBUG Or VFF_PRERELEASE
dwFileOS As Long ' e.g. VOS_DOS_WINDOWS16
dwFileType As Long ' e.g. VFT_DRIVER
dwFileSubtype As Long ' e.g. VFT2_DRV_KEYBOARD
dwFileDateMS As Long ' e.g. 0
dwFileDateLS As Long ' e.g. 0
End Type
Type fBuffer
Item As String * 1024
End Type
Private Type SYSTEM_INFO
dwOemID As Long
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
dwReserved As Long
End Type
Const VER_PLATFORM_WIN32s = 0
Const VER_PLATFORM_WIN32_WINDOWS = 1 ' Windows 95
Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
strReserved 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 Function atGetSysStatus(intStatus As Integer) As Variant
'
'Purpose: Retrieve system status information
'
'Accepts: intStatus: which piece of information to retrieve
' 1: The number of CPUs in the system
' 2: The type of CPUs in the system
'
'Returns: The requested information
On Error Resume Next
Dim SI As SYSTEM_INFO
Dim CPUType$
GetSystemInfo SI
Select Case intStatus
Case 1
atGetSysStatus = SI.dwNumberOrfProcessors
Case 2
CPUType = SI.dwProcessorType
If CPUType = "586" Then
atGetSysStatus = "Pentium"
Else
atGetSysStatus = CPUType
End If
Case Else
atGetSysStatus = 0
End Select
End Function
Function atDiskFreeSpace(Drive As String) As String
'
'Purpose: Return Free Space
'
'Accepts: A Drive letter
'
'Returns: Disk space available
'
On Error GoTo Err_DF
Dim wResult
Dim TotalSpace As Long
Dim TotalSpaceMB As Single
Dim FreeSpace As Long
Dim FreeSpaceMB As Single
Dim PercentFree As Single
Dim Path As String
Dim Sectors As Long
Dim Bytes As Long
Dim FClusters As Long
Dim TClusters As Long
Dim ErrorMode&
If IsNull(Drive) Then Exit Function
'
'Set the error mode for the system so that "system errors" are ignored
'and we let Access handle the errors, capture the return value so that
'the error mode can be reset to its initial setting upon exit from the
'function
'
ErrorMode = api_SetErrorMode(SEM_FAILCRITICALERRORS)
wResult = Dir(Drive & ":\*.*")
Path = Drive & ":\" & Chr$(0)
wResult = api_GetDiskFreeSpace(Path, Sectors, Bytes, FClusters,
TClusters)
TotalSpace = Sectors * Bytes * TClusters
TotalSpaceMB = (TotalSpace / 1024) / 1024
FreeSpace = Sectors * Bytes * FClusters
FreeSpaceMB = (FreeSpace / 1024) / 1024
PercentFree = (FreeSpace / TotalSpace) * 100
If TotalSpace = -1 Then
atDiskFreeSpace = "Drive Not Available"
Else
If FreeSpaceMB < 1000 And TotalSpaceMB < 1000 Then
atDiskFreeSpace = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% of " & Format$(TotalSpaceMB, "0.##") & "
MB"
ElseIf FreeSpaceMB < 1000 And TotalSpaceMB > 1000 Then
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpace = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% of " & Format$(TotalSpaceMB, "0.##") & "
GB"
Else
FreeSpaceMB = FreeSpaceMB / 1024
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpace = Format$(FreeSpaceMB, "###0.##") & " GB: " &
Format$(PercentFree, "0.##") & "% of " & Format$(TotalSpaceMB, "0.##") & "
GB"
End If
End If
ErrorMode = api_SetErrorMode(ErrorMode)
Exit_DF:
Exit Function
Err_DF:
If Err = 71 Then
MsgBox "There is no disc in Drive " & Drive & ":, the drive door is
not closed, or the current disc has not been formatted.", 16, "System
Information"
ElseIf Err = 68 Then
atDiskFreeSpace = "Drive Not Available"
Resume Exit_DF
ElseIf Err = 75 Or 76 Then
MsgBox "Drive " & Drive & ": is not accessable. If the Drive is a
CDROM then make sure it is turned on and/or a disk is in the Drive.", 16,
"System Information "
ElseIf Err = 3043 Then
MsgBox "The Network or Disc Drive " & Drive & " is unavailable or
has produced an error", 48, "System Information"
Else
MsgBox "Error " & Err.Description, 48, "System Information"
End If
ErrorMode = api_SetErrorMode(ErrorMode)
atDiskFreeSpace = "Drive Not Available"
Resume Exit_DF
End Function
Function atDiskFreeSpaceEx(Drive As String) As String
'
'Purpose: Return Free Space on Drives
'
'Accepts: A Drive letter
'
'Returns: Disk space available
'
On Error GoTo Err_DF
Dim wResult
Dim TotalSpace As Long
Dim TotalSpaceMB As Double
Dim FreeSpace As Long
Dim FreeSpaceMB As Double
Dim PercentFree As Single
Dim Path As String
Dim FreeBytesCaller As Currency
Dim TotalBytes As Currency
Dim TotalFreeBytes As Currency
Dim Sectors As Long
Dim Bytes As Long
Dim FClusters As Long
Dim TClusters As Long
Dim ErrorMode&
If IsNull(Drive) Then Exit Function
'
'Set the error mode for the system so that "system errors" are ignored
'and we let Access handle the errors, capture the return value so that
'the error mode can be reset to its initial setting upon exit from the
'function
'
ErrorMode = api_SetErrorMode(SEM_FAILCRITICALERRORS)
wResult = Dir(Drive & ":\*.*")
Path = Drive & ":\" & Chr$(0)
On Error Resume Next
'
'Only supported on Win95 OSR2 and above and NT 4 and above
'
wResult = api_GetDiskFreeSpaceEx(Path, FreeBytesCaller, TotalBytes,
TotalFreeBytes)
If Err = 0 Then
TotalSpaceMB = ((TotalBytes * 10000) / 1024) / 1024
FreeSpaceMB = ((FreeBytesCaller * 10000) / 1024) / 1024
Else
'
'Win95 OSR1
'
wResult = api_GetDiskFreeSpace(Path, Sectors, Bytes, FClusters,
TClusters)
TotalSpace = Sectors * Bytes * TClusters
TotalSpaceMB = (TotalSpace / 1024) / 1024
FreeSpace = Sectors * Bytes * FClusters
FreeSpaceMB = (FreeSpace / 1024) / 1024
End If
On Error GoTo Err_DF
PercentFree = (FreeSpaceMB / TotalSpaceMB) * 100
If TotalSpaceMB = -1 Then
atDiskFreeSpaceEx = "Drive Not Available"
Else
If FreeSpaceMB < 1000 And TotalSpaceMB < 1000 Then
atDiskFreeSpaceEx = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% de " & Format$(TotalSpaceMB, "0.##") & "
MB"
ElseIf FreeSpaceMB < 1000 And TotalSpaceMB > 1000 Then
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpaceEx = Format$(FreeSpaceMB, "###0.##") & " MB: " &
Format$(PercentFree, "0.##") & "% de " & Format$(TotalSpaceMB, "0.##") & "
GB"
Else
FreeSpaceMB = FreeSpaceMB / 1024
TotalSpaceMB = TotalSpaceMB / 1024
atDiskFreeSpaceEx = Format$(FreeSpaceMB, "###0.##") & " GB: " &
Format$(PercentFree, "0.##") & "% de " & Format$(TotalSpaceMB, "0.##") & "
GB"
End If
End If
ErrorMode = api_SetErrorMode(ErrorMode)
Exit_DF:
Exit Function
Err_DF:
If Err = 71 Then
MsgBox "There is no disc in Drive " & Drive & ":, the drive door is
not closed, or the current disc has not been formatted.", 16, "System
Information"
ElseIf Err = 68 Then
atDiskFreeSpaceEx = "Drive Not Available"
Resume Exit_DF
ElseIf Err = 75 Or 76 Then
MsgBox "Drive " & Drive & ": is not accessable. If the Drive is a
CDROM then make sure it is turned on and/or a disk is in the Drive.", 16,
"System Information "
ElseIf Err = 3043 Then
MsgBox "The Network or Disc Drive " & Drive & " is unavailable or
has produced an error", 48, "System Information"
Else
MsgBox "Error " & Err.Description, 48, "System Information"
End If
ErrorMode = api_SetErrorMode(ErrorMode)
atDiskFreeSpaceEx = "Drive Not Available"
Resume Exit_DF
End Function
Public Function atGetColourCap() As String
'
'Purpose: Get the colour depth setting for the monitor
'
'Accepts: Nothing, calls GetDeviceCaps for the Display
'
'Returns: String Value base on the number of Bits and color
' Planes
'
On Error GoTo Err_Colour
Dim Planes As Integer
Dim Bits As Integer
Planes = atGetdevcaps(14)
Bits = atGetdevcaps(12)
If Planes = 1 Then
Select Case Bits
Case 8
atGetColourCap = "256"
Case 15
atGetColourCap = "32K"
Case 16
atGetColourCap = "64K"
Case 24
atGetColourCap = "16 Mil"
Case 32
atGetColourCap = "True"
End Select
ElseIf Planes = 4 Then
atGetColourCap = 16
Else
atGetColourCap = "Unk"
End If
Exit_Colour:
Exit Function
Err_Colour:
atGetColourCap = "Unk"
Resume Exit_Colour
End Function
Public Function atGetdevcaps%(ByVal intCapability%)
'
' Purpose: Returns information on the capabilities of
' a given device. Which device is determined
' by the arguments to api_CreateIC. Which
' capability is determined by the intCapability
' argument which is one of the constants
' defined for the GetDeviceCaps Windows API
' function.
'
' Arguments: intCapability - index of capability to check
' see win32api.txt for list of values
'
' Returns: Results of call to GetDeviceCaps
'
On Error GoTo getdevcapsError
'LogPixels X = 88 for capability
'LogPixels Y = 90 for capability
Dim hdc& 'handle for the device context
'Specify the device -- use "DISPLAY' to check screen capabilities
'
Const DRIVER_NAME = "DISPLAY"
Const DEVICE_NAME = 0&
Const OUTPUT_DEVICE = 0&
Const LPDEVMODE = 0&
'Get a handle to a device context (hDC)
'
hdc = api_CreateIC(DRIVER_NAME, DEVICE_NAME, OUTPUT_DEVICE, LPDEVMODE)
If hdc Then
'If a valid hDC was returned, call GetDeviceCaps and
'then release the DC
'
atGetdevcaps = api_GetDeviceCaps(hdc, intCapability)
hdc = api_DeleteDC(hdc)
End If
getdevcapsExit:
Exit Function
getdevcapsError:
MsgBox "Error: " & Err.Description, 48, "System Information"
Resume getdevcapsExit
End Function
Function atGetjetver() As String
'
'Purpose: Returns Version information on Jet DB Engine
' Based on the Version of Access Used
'
Dim Buffer As fBuffer
Dim VInfo As VS_FIXEDFILEINFO
Dim stBuf() As Byte
Dim lSize As Long
Dim stUnused As Long
Dim ErrCode As Long
Dim VerNum As Variant
Dim lVerPointer As Long
Dim lVerbufferLen As Long
Dim Jet$
If SysCmd(acSysCmdAccessVer) < 8 Then
Jet = Jet_FILENAME
Else
Jet = Jet35_FILE
End If
lSize = ac_GetFileVersionInfoSize(Jet, stUnused)
ReDim stBuf(lSize)
ErrCode = ac_GetFileVersionInfo(Jet, 0&, lSize, stBuf(0))
ErrCode = ac_VerQueryValue(stBuf(0), "\", lVerPointer, lVerbufferLen)
If ErrCode <> 0 Then
ac_MoveMemory VInfo, lVerPointer, Len(VInfo)
VerNum = Format$(VInfo.dwFileVersionMSh) & "." & _
Format$(VInfo.dwFileVersionMSl) & "." & _
Format$(VInfo.dwFileVersionLSh) & "." & _
Format$(VInfo.dwFileVersionLSl)
End If
atGetjetver = VerNum
End Function
Function atWinver(intOSInfo%) As Variant
'
'Purpose: Retrieve operating system information
'
'Accepts: intOSInfo: which piece of information to retrieve
' 0: Major Version
' 1: Minor version
' 2: Platform ID
'
' Returns: OS supplied Information
'
Dim OSInfo As OSVERSIONINFO
Dim dwReturn&
Const PLAT_WINDOWS = 1
Const PLAT_WIN_NT = 2
'Set the size equal to length of structure
'
OSInfo.dwOSVersionInfoSize = Len(OSInfo)
If GetVersionEx(OSInfo) Then
Select Case intOSInfo
Case 0
atWinver = OSInfo.dwMajorVersion
Case 1
atWinver = OSInfo.dwMinorVersion
Case 2
dwReturn = OSInfo.dwPlatformId
If dwReturn = PLAT_WINDOWS Then
atWinver = "Windows"
Else
atWinver = "Windows NT"
End If
Case 3
If OSInfo.dwPlatformId = PLAT_WINDOWS Then
atWinver = OSInfo.dwBuildNumber And &HFFF
Else
atWinver = OSInfo.dwBuildNumber
End If
End Select
Else
atWinver = 0
End If
End Function
Public Function atGetMem(intInfoItem As Integer) As Variant
'
'Purpose: Retrieve system memory use information
'
'Accepts: intInfoItem: Memory Info to retrieve
' 1: Total physical memory in bytes
' 2: Available physical memory in bytes
'
'Returns: The current memory use information
'
On Error Resume Next
Dim MemStat As MEMORYSTATUS
MemStat.dwLength = Len(MemStat)
Call GlobalMemoryStatus(MemStat)
Select Case intInfoItem
Case 1
atGetMem = MemStat.dwTotalPhys
Case 2
atGetMem = MemStat.dwAvailPhys
Case 3
atGetMem = MemStat.dwTotalVirtual
Case 4
atGetMem = MemStat.dwAvailVirtual
Case 5
atGetMem = MemStat.dwTotalPageFile
Case 6
atGetMem = MemStat.dwAvailPageFile
Case 7
atGetMem = MemStat.dwMemoryLoad
Case Else
atGetMem = 0
End Select
End Function
Public Function atDriveType(Drive As String) As Integer
'
'Purpose: Gets a integer value representing the drive type
'
'Accepts: A drive letter
'Returns: The drive type; used by after update of drive combo
' to change the drive picture
'
On Error GoTo Err_DT
Dim wResult As Long
Dim Path As String
Path = Drive & ":\" & Chr$(0)
wResult = api_GetDriveType(Path)
atDriveType = wResult
Exit Function
Err_DT:
atDriveType = 0
Exit Function
End Function
Public Function atCNames(UOrC As Integer) As String
'
'Purpose: Returns the User LogOn Name or ComputerName
'
'Accepts: UorC; 1=User, anything else = computer
'
'Returns: The Windows Networking name of the user or computer
'
On Error Resume Next
Dim NBuffer As String
Dim Buffsize As Long
Dim Wok As Long
Buffsize = 256
NBuffer = Space$(Buffsize)
If UOrC = 1 Then
Wok = api_GetUserName(NBuffer, Buffsize)
atCNames = Trim$(NBuffer)
Else
Wok = api_GetComputerName(NBuffer, Buffsize)
atCNames = Trim$(NBuffer)
End If
End Function
T
TC
Copy the following code into a standard module (ie. a module that is
not attached to any form.) Save the module. Then type Ctrl-g to go to
the debug window, type "zz" (without the quotes) and press Enter.
'------------------------------------------------------------------------------------------------
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As
Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Public Sub zz()
Dim lngWidth As Long, lngHeight As Long
lngWidth = GetSystemMetrics(SM_CXSCREEN)
lngHeight = GetSystemMetrics(SM_CYSCREEN)
MsgBox lngWidth & " x " & lngHeight & " pixels"
End Sub
'------------------------------------------------------------------------------------------------
HTH,
TC (MVP Access)
http://tc2.atspace.com
not attached to any form.) Save the module. Then type Ctrl-g to go to
the debug window, type "zz" (without the quotes) and press Enter.
'------------------------------------------------------------------------------------------------
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As
Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Public Sub zz()
Dim lngWidth As Long, lngHeight As Long
lngWidth = GetSystemMetrics(SM_CXSCREEN)
lngHeight = GetSystemMetrics(SM_CYSCREEN)
MsgBox lngWidth & " x " & lngHeight & " pixels"
End Sub
'------------------------------------------------------------------------------------------------
HTH,
TC (MVP Access)
http://tc2.atspace.com