'------------------------------------------------------------------------------
'以下在类模块中： (system.cls)
Option Explicit
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------'---------------------------------------------------------------------------
' API declarations in order to obtain names (computer and user names)
'---------------------------------------------------------------------------
Private Declare Function apiUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function apiCompName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'---------------------------------------------------------------------------
' API declarations in order to obtain the Windows / System and Temporary
' directories.
'---------------------------------------------------------------------------
Private Declare Function apiWindDir Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function apiSysDir Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function apiTempDir Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'---------------------------------------------------------------------------
' API declarations in order to obtain Memory and System information.
'---------------------------------------------------------------------------
Private Declare Sub apiMemStatus Lib "kernel32" Alias "GlobalMemoryStatus" (lpBuffer As MEMORYSTATUS)
Private Type MEMORYSTATUS ' size of 'Type' = 8 x 4 bytes = 32 (a Long is 4 Bytes)
dwLength As Long ' This need to be set at the size of this 'Type' = 32
dwMemoryLoad As Long ' Gives global indication of used RAM (in %)
dwTotalPhys As Long ' Gives total RAM of the computer
dwAvailPhys As Long ' Gives the amount of free RAM
dwTotalPageFile As Long ' I don't use this (don't know what it means)
dwAvailPageFile As Long ' I don't use this (don't know what it means)
dwTotalVirtual As Long ' I don't use this (don't know what it means)
dwAvailVirtual As Long ' I don't use this (don't know what it means)
End TypePrivate Declare Sub apiSystemInfo Lib "kernel32" Alias "GetSystemInfo" (lpSystemInfo As SYSTEM_INFO)
Private Type SYSTEM_INFO ' size of 'Type' = 9 x 4 bytes = 36
dwOemID As Long
dwPageSize As Long ' Must be set at the size of this 'Type'
lpMinimumApplicationAddress As Long ' ?
lpMaximumApplicationAddress As Long ' ?
dwActiveProcessorMask As Long ' Gives the active processor number
dwNumberOfProcessors As Long ' Gives number of processors
dwProcessorType As Long ' Gives the processor type (386,486,586)
dwAllocationGranularity As Long ' ?
dwReserved As Long ' ?
End Type
'---------------------------------------------------------------------------
' API declaration to get information about the drives.
'---------------------------------------------------------------------------
Private Declare Function apiDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function apiDiskFreeSpace 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 apiFastFreeSpace Lib "STKIT432.DLL" Alias "DISKSPACEFREE" () As Long
Private Declare Function apiGetDrives Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function apiSerialNumber 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 LongPrivate Declare Function apiMonitors Lib "winspool.drv" Alias "EnumMonitorsA" (ByVal pName As String, ByVal Level As Long, pMonitors As Byte, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Type MONITOR_INFO_1
pName As String
End Type
Private Type MONITOR_INFO_2
pName As String
pEnvironment As String
pDLLName As String
End Type'---------------------------------------------------------------------------
' API declarations to obtain the Windows version and the type of
' keyboard.
'---------------------------------------------------------------------------
Private Declare Function apiGetVersion Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
' size of 'Type' = (5 x 4 bytes) = 20 bytes (the 5 Longs)
' 128 bytes (fixed-length string)
' ----- +
' 148 bytes
dwOSVersionInfoSize As Long ' Has to be set to size of 'type'= 148
dwMajorVersion As Long ' Gives the Major version
dwMinorVersion As Long ' Gives the Minor version
dwBuildNumber As Long ' Gives the buildnumber (I don't use it)
dwPlatformId As Long ' Gives the operating system.
szCSDVersion As String * 128 ' ?
End TypePrivate Declare Function apiKeyboardType Lib "user32" Alias "GetKeyboardType" (ByVal nTypeFlag As Long) As LongPublic Sub DriveInfo(ByVal strRoot As String, ByRef lngTotalSpace As Long, ByRef lngFreeSpace As Long)
'---------------------------------------------------------------------------
' SUB: DriveInfo
'
' This Sub returns the amount of total disk space and free disk space. The
' API call return the number of Clusters, Free Clusters, Sectors per cluster,
' and Bytes per cluster. By multiplying these values you can get the
' required information.
'
' lngTotalSpace and lngFreeSpace give the amount of space in BYTES!
' (see PutPoints)
'
' IN: strRoot - String containing the root of the drive you want to
' check. (e.g. "A:\", or "C:\")
'
' OUT: lngTotalSpace - Long containing the total disk space of the drive.
' lngFreeSpace - Long containing the amount of free disk space.
'
' If the API call fails, Zero is returned in both variables.
'---------------------------------------------------------------------------
'
Dim TotalClusters As Long
Dim FreeClusters As Long
Dim SectorsPerCluster As Long
Dim BytesPerSector As LongIf apiDiskFreeSpace(strRoot, SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) Then
' If the call succeeds return the asked amount of diskspace.
lngTotalSpace = SectorsPerCluster * BytesPerSector * (TotalClusters \ 1024)
lngFreeSpace = SectorsPerCluster * BytesPerSector * (FreeClusters \ 1024)
Else
' Otherwise return zero.
lngTotalSpace = 0
lngFreeSpace = 0
End IfEnd Sub
Public Sub Drives(ByRef intRemovable As Integer, ByRef intNotRemovable As Integer, ByRef intCD As Integer, ByRef intRAM As Integer, ByRef intNetwork As Integer)
'---------------------------------------------------------------------------
' SUB: Drives
'
' Returns the number of removable, fixed, CD-ROM, RAM, and Network drives
' that are connected to your computer.
'
' THIS FUNCTION USES THE DRIVETYPE FUNCTION, SO IF YOU MODIFY THAT FUNCTION
' YOU MUST ALSO MODIFY THIS FUNCTION.
'
' OUT: intRemovable - Integer containing the number of removable drives
' intNotRemovable - Integer containing the number of fixed drives
' intCD - Integer containing the number of CD drives
' intRAM - Integer containing the number of RAM disks
' int Network - Integer containing the number of Network drives
'
'---------------------------------------------------------------------------
'
Dim Retrn As Long
Dim Buffer As Long
Dim Temp As String
Dim intI As Integer
Dim Read As String
Dim Counter As Integer
Buffer = 10Again:
Temp = Space$(Buffer)
Retrn = apiGetDrives(Buffer, Temp)
' Call the API function.If Retrn > Buffer Then ' If the API returned a value that is bigger than Buffer,
Buffer = Retrn ' than the Buffer isn't big enough to hold the information.
GoTo Again ' In that case adjust the Buffer to the right size (returned by
End If ' the API) and try again.
' The API returns something like :
' A:\*B:\*C:\*D:\** , with * = NULL character
' 1234123412341234
' \ 1 \ 2 \ 3 \ 4 '
' So we start reading three characters, we step 4 further (the three we read + the
' NULL-character), and we read again three characters, step 4, ect.Counter = 0
For intI = 1 To (Buffer - 4) Step 4 Counter = Counter + 1
Read = Mid$(Temp, intI, 3)
Select Case DriveType(Read)
Case "Removable drive"
intRemovable = intRemovable + 1
Case "Fixed drive"
intNotRemovable = intNotRemovable + 1
Case "Network drive"
intNetwork = intNetwork + 1
Case "CD-ROM drive"
intCD = intCD + 1
Case "RAM-disk"
intRAM = intRAM + 1
End SelectNextEnd SubPublic Function DriveType(ByVal strRoot As String) As String
'---------------------------------------------------------------------------
' FUNCTION: DriveType
'
' This function returns information about the drive you asked for. It will
' return whether the drive is a Removable drive, a non-removable (fixed)
' drive, a CD-ROM drive, a RAM drive or a Network drive.
'
' IN: strRoot - String containing the root of a drive. (e.g. "C:\")
'
' OUT: DriveType - String containing type of drive.
'
' If the function fails a empty string is returned.
'
' You can also re-program this Function so that it doens't return a string,
' but it returns the value. That can be easier if you want to work with
' the returned information. I let it return a string, so that I can print
' it.
'
' THE DRIVES FUNCTION USES THIS FUNCTION, SO IF YOU MODIFY THIS FUNCTION,
' YOU ALSO HAVE TO MODIFY THAT FUNCTION!
'
'---------------------------------------------------------------------------
'
Dim lngType As Long
Const DRIVE_CDROM = 5 ' Some API constants required to
Const DRIVE_FIXED = 3 ' get the difference between the
Const DRIVE_RAMDISK = 6 ' drive types.
Const DRIVE_REMOTE = 4
Const DRIVE_REMOVABLE = 2lngType = apiDriveType(strRoot)
' The API returns a value in lngType. Use the Constants to
' make the strings.Select Case lngType
Case DRIVE_REMOVABLE
DriveType = "Removable drive"
Case DRIVE_FIXED
DriveType = "Fixed drive"
Case DRIVE_REMOTE
DriveType = "Network drive"
Case DRIVE_CDROM
DriveType = "CD-ROM drive"
Case DRIVE_RAMDISK
DriveType = "RAM-disk"
Case Else
DriveType = "" ' If the API returns an error, we return a empty string
End SelectEnd Function
Public Function PutPoints(ByVal lngNumber As Long) As String
'---------------------------------------------------------------------------
' FUNCTION: PutPoints
'
' YOU'D BETTER RENAME THIS FUNCTION, BECAUSE I COULDN'T THINK OF A GOOD
' NAME. (I should have used "dots" instead of "points".....)
'
' This function makes the values returned by the DriveInfo (lngTotalSpace and
' lngFreeSpace) more readable. It put dot (.) in the number.
' (hmmm... how can I explain this right??)
' e.g. if you pass "1000" in this function it will return "1.000"
' even so: "123456789" --> "123.456.789"
' "1234567" --> "1.234.567"
'
' I don't know if it works perfectly, but up to now I haven't discovered any
' errors.
'
' IN: lngNumber - Long containing the number to be converted.
'
' OUT: PutPoints - String containing the number with dots inserted.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PLEASE NOTE THAT THIS IS VERY HARD TO EXPLAIN FOR ME IN ENGLISH. I HOPE '
' YOU UNDERSTAND WHAT I AM DOING HERE!! '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' It is also possible to do the following:
' PutPoints = Format(lngNumber, "###.###.###.###.###.###")
'
' But I have noticed that when you pass zero to this format function, it
' returns an empty string!
'
'---------------------------------------------------------------------------
'
Dim NumOfPlaces As Integer
Dim Counter As Integer
Dim CurValue As String
Dim Remainder As LongIf Len(lngNumber) > 3 Then ' Check if the number is > 999, otherwise you don't need
' putting dots in it.
NumOfPlaces = Len(CStr(lngNumber)) \ 3
' Count the number of dot that must be inserted. Divide the lngNumber by three
' to obtain this. Note that I use the "\" to divide. I only want the value before
' the dot. (in other words: I don't want decimals (not 1.23233, but 1))
If NumOfPlaces = Len(CStr(lngNumber)) / 3 Then ' I the number is exactly dividable by
NumOfPlaces = NumOfPlaces - 1 ' three, one dot less is needed.
End If ' e.g. 111000 requires only one dot
' and not two.
For Counter = 0 To NumOfPlaces - 1
' Read the last three numbers in lngNumber and add a dot before it. Then read the next
' three numbers (with a dot before it) and add the part of the first time behind it.
PutPoints = "." + CStr(Mid$(lngNumber, Len(CStr(lngNumber)) - ((Counter * 3) + 2), 3)) + CurValue
CurValue = PutPoints ' Store the part we already have in CurValue
Next
Remainder = Len(CStr(lngNumber)) - (((Counter - 1) * 3) + 2) - 1
PutPoints = CStr(Left$(lngNumber, Remainder)) + CurValue
' Read the last numbers that must be before the first dot and add it to the PutPoint
' and then return it.Else
' I the number doens't need any dots, return the unaltered number.
PutPoints = lngNumberEnd If
End Function
Public Function FastDiskSpace(ByVal strRoot As String) As Long
'---------------------------------------------------------------------------
' FUNCTION: FastDiskSpace
'
' Returns the amount of free disk space. See also the DriveInfo function.
' This function is faster because here we don't have to multiply some
' values in order to get the diskspace.
'
' The amount of free space is given in BYTES! (See PutPoints)
'
' IN: strRoot - String containing the root of the drive you want to
' check out.
'
' OUT: FastDiskSpace - Long containing the amount of free space (in bytes)
'---------------------------------------------------------------------------
'
Dim strCurrent As String
On Error GoTo Bliep '(Dutch variation of Beep, means an error)strCurrent = CurDir ' Save the current drive
ChDrive strRoot ' Change to the requested driveFastDiskSpace = apiFastFreeSpace 'Get the free spaceChDrive Left$(strCurrent, 2) ' Return to the saved drive
ChDir strCurrent ' Return to the saved directoryExit FunctionBliep:
' If the drive wasn't ready or something
FastDiskSpace = 0 ' Return zero as free disk space
ChDrive Left$(strCurrent, 2) ' Retur to the saved drive
ChDir strCurrent ' and directoryEnd FunctionPublic Sub FreeMemory(ByRef btePercentUsed As Byte, ByRef lngTotalRam As Long, ByRef lngFreeRam As Long)
'---------------------------------------------------------------------------
' SUB: FreeMemory
'
' Returns information about your RAM (-memory).
' lngTotalRam en lngFreeRam return the amount of RAM in Kbytes!
'
' OUT: btePercentUsed - Byte that gives an indication of used RAM in %
' lngTotalRam - Long containing the amount of total RAM
' lngFreeRam - Long containing the aomunt of free RAM
'---------------------------------------------------------------------------
'
Dim Memory As MEMORYSTATUSMemory.dwLength = 32
' This must be set to the size of the structure before the callapiMemStatus Memory
' Call the API. This function fills the Memory structure (Type) with
' a lot of information. I only use three parts of it.' Fill the variables with the desired values.
btePercentUsed = Memory.dwMemoryLoad
lngTotalRam = Memory.dwTotalPhys / 1024
lngFreeRam = Memory.dwAvailPhys / 1024End Sub
Public Function FunctionKeys() As Byte
'---------------------------------------------------------------------------
' FUNCTION: FunctionKeys
'
' Returns the number of function keys your keyboard has.
' See the KeyboardType function for more information about your keyboard.
'---------------------------------------------------------------------------
'
FunctionKeys = apiKeyboardType(2)End Function
Public Function KeyboardType() As String
'---------------------------------------------------------------------------
' FUNCTION: KeyboardType
'
' Returns a string containing the type of Keyboard you use.
'
'---------------------------------------------------------------------------
'
Dim intBuffer As LongintBuffer = apiKeyboardType(0)
' Call the API. The zero specifies that I want to get information
' about the keyboard type. The FunctionKeys function uses the
' same API call, only with a "2" specified.
' These are all constants I've found somewhere, so I can't explain
' it. It's just true.
Select Case intBuffer
Case 1
KeyboardType = "IBM PC/XT or compatible (83 key)"
Case 2
KeyboardType = "Olivetti ""ico"" (102 key)"
Case 3
KeyboardType = "IBM PC/AT or compatible (84 key)"
Case 4
KeyboardType = "IBM enhanced (101 or 102 key)"
Case 5
KeyboardType = "Nokia 1050 or compatible"
Case 6
KeyboardType = "Nokia 9140 or compatible"
Case 7
KeyboardType = "Japanese"
End SelectEnd Function
Public Sub SystemInfo(ByRef strProcessor As String, ByRef lngNumOfProcessors As Long, ByRef lngActiveProcessor As Long)
'---------------------------------------------------------------------------
' SUB: SystemInfo
'
' This Sub returns the number of processors, the active processor and
' the type of the processor.
'
' OUT: strProcessor - String containing the type of processor.
' lngNumOfProcessors - Long containing the number of processors.
' lngActiveProcessor - Long containing the number of the active
' processor (mostly 1)
'---------------------------------------------------------------------------
'
Dim SI As SYSTEM_INFOapiSystemInfo SI
' The API call fills the SI type with a lot of information
' but I only use three parts of it.
lngActiveProcessor = SI.dwActiveProcessorMask
lngNumOfProcessors = SI.dwNumberOfProcessorsSelect Case SI.dwProcessorType
Case 386
strProcessor = "80386" ' Return the processor type.
Case 486 ' Windows 95 only recognises
strProcessor = "80486" ' these three.
Case 586
strProcessor = "Intel Pentium"
End Select
End Sub
Public Function TempDir() As String
'---------------------------------------------------------------------------
' FUNCTION: TempDir
'
' Get the Temporary directory windows uses.
'
' OUT: TempDir - String containing the directory.
'
' If the function fails a empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API and remove the spaces using RTrim. Next, remove the terminating
' character using StripTerminator, and add a backslash, when if it wasn't
' already there.
'---------------------------------------------------------------------------
If apiTempDir(50, Bufstr) > 0 Then
TempDir = Bufstr
TempDir = RTrim(TempDir)
TempDir = StripTerminator(TempDir)
If Right$(TempDir, 1) <> "\" Then
TempDir = TempDir + "\"
End If
Else
TempDir = ""
End If
End Function
Public Function SystemDir() As String
'---------------------------------------------------------------------------
' FUNCTION: SystemDir
'
' Gets the WINDOWS\SYSTEM directory.
'
' Returns a string containing the full path, ends with a "\". If the
' call fails a empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API and remove the spaces using RTrim. Remove the terminating
' character and add a backslash when it isn't already there.
'---------------------------------------------------------------------------
If apiSysDir(Bufstr, 50) > 0 Then
SystemDir = Bufstr
SystemDir = RTrim(SystemDir)
SystemDir = StripTerminator(SystemDir)
If Right$(SystemDir, 1) <> "\" Then
SystemDir = SystemDir + "\"
End If
Else
SystemDir = ""
End If
End Function
Public Function ComputerName() As String
'---------------------------------------------------------------------------
' FUNCTION: ComputerName
'
' This function retrieves the Computer name (is the computer is connected to
' a network) and removes the terminating character that the Windows API
' returns.
'
' OUT: ComputerName - String containing the name of the computer. If the
' API call fails, an empty string is returned.
'
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API and remove the empty spaces behind the name using RTrim.
' Afterwards remove the terminating character.
'---------------------------------------------------------------------------
If apiCompName(Bufstr, 50) > 0 Then
ComputerName = Bufstr
ComputerName = RTrim(ComputerName)
ComputerName = StripTerminator(ComputerName)
Else
ComputerName = ""
End If
End Function
Private Function StripTerminator(ByVal strString As String) As String
'---------------------------------------------------------------------------
' FUNCTION: StripTerminator
'
' Returns a string without any zero terminator. Typically,
' this was a string returned by a Windows API call.
'
' IN: [strString] - String to remove terminator from
'
' Returns: The value of the string passed in minus any
' terminating zero.
'
'
' THIS FUNCTION I GOT FROM THE SETUP PROJECT THAT CAME WITH VISUAL BASIC 4.
'---------------------------------------------------------------------------
'
Dim intZeroPos As Integer intZeroPos = InStr(strString, Chr$(0))
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
StripTerminator = strString
End IfEnd Function
Public Function UserName() As String
'---------------------------------------------------------------------------
' FUNCTION: UserName
'
' Get the name of the user.
'
' OUT: UserName - String containing the name of the user of the computer.
'
' If the function fails, an empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API, remove the spaces using RTrim, remove the NULL-character
' using StripTerminator.
'---------------------------------------------------------------------------
If apiUserName(Bufstr, 50) > 0 Then
UserName = Bufstr
UserName = RTrim(UserName)
UserName = StripTerminator(UserName)
Else
UserName = ""
End If
End Function
Public Function SerialNumber(ByVal strRoot As String) As String
'---------------------------------------------------------------------------
' FUNCTION: SerialNumber
'
' Returns the serial number of a drive. It returns the number exactly the
' same as DOS does (hexadecimal value e.g. : 1104-224E)
'
' IN: strRoot - String containing the root of a drive (e.g. "A:\").
'
' OUT: SerialNumber - String containing the serial number.
'
' If the function fails (because the drive wasn't ready or something), the
' function returns "0000-0000" as the serial number.
'
'---------------------------------------------------------------------------
'
Dim VolLabel As String
Dim VolSize As Long
Dim SerNum As Long
Dim MaxLen As Long
Dim Flags As Long
Dim Name As String
Dim NameSize As Long
Dim Check As StringIf apiSerialNumber(strRoot, VolLabel, VolSize, SerNum, MaxLen, Flags, Name, NameSize) Then
' This function returns a lot more, but I can get that information via another function. Check = Format(Hex(SerNum), "00000000")
' Make sure that the length = 8. So convert "123456" to "00123456"
SerialNumber = Left$(Check, 4) + "-" + Right$(Check, 4)
' Split the number in two parts of four and add a "-" between them.Else
' Return "0000-0000" is the function fails.
SerialNumber = "0000-0000"End IfEnd FunctionPublic Function VolumeLabel(ByVal strRoot As String) As String
'---------------------------------------------------------------------------
' FUNCTION: VolumeLabel
'
' Returns the VolumeLabel of a drive. This function doesn't need an API
' Call, because the Visual Basic command "Dir" returns this label.
'
' IN: strRoot - String containing the root of the drive you want
' the Volume Label of.
'
' OUT: VolumeLabel - String containing the Volume Label.
'
' If the function fails an empty string is returned. When the drive hasn't
' got a name, "NoName" is returned as the Volume label.
'---------------------------------------------------------------------------
'
On Error GoTo FurtherVolumeLabel = Dir(strRoot, vbVolume)
VolumeLabel = StripTerminator(VolumeLabel)
' Get the volume label and remove the NULL character.If VolumeLabel = "" Then VolumeLabel = "NoName"
' Set the label to "NoName", when the drive hasn't got a name.Exit Function
Further:
VolumeLabel = ""
' If the function fails, return an empty string.End FunctionPublic Function WinDir() As String
'---------------------------------------------------------------------------
' FUNCTION: WinDir
'
' Returns the Windows directory (Mostly "C:\WINDOWS\")
'
' If the function fails an empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API, remove the extra spaces using RTrim, remove the NULL-character
' using StripTerminator, and add a backslash.
'---------------------------------------------------------------------------
If apiWindDir(Bufstr, 50) > 0 Then
WinDir = Bufstr
WinDir = RTrim(WinDir)
WinDir = StripTerminator(WinDir)
If Right$(WinDir, 1) <> "\" Then
WinDir = WinDir + "\"
End If
Else
WinDir = ""
End If
End Function
Public Sub WinVer(ByRef intMajor As Integer, ByRef intMinor As Integer, ByRef strPlatform As String)
'---------------------------------------------------------------------------
' SUB: WinVer
'
' This sub returns information about the operating system, and about
' the Windows Version.
'
' e.g. Windows 3.11
' The sub will return:
' - intMajor = 3
' - intMinor = 11
' - strPlatform = Windows 3.11
'
' OUT: intMajor - Integer containing the major version of Windows.
' intMinor - Integer containing the minor version of windows.
'
' strPlatfrom returns one of the following :
' Windows 95
' Windows NT
' Windows + Version
'
' If the call fails intMajor = 0, intMinor = 0, and strPlatform = ""
'---------------------------------------------------------------------------
'
Dim OSystem As OSVERSIONINFOOSystem.dwOSVersionInfoSize = 148
' The size of the structure must be set before the call.If apiGetVersion(OSystem) Then
' Call the API. It fills the OSystem type. intMajor = OSystem.dwMajorVersion ' Store the Major version in intMajor
intMinor = OSystem.dwMinorVersion ' Store the Minor version in intMinor
Select Case OSystem.dwPlatformId ' Set strPlatform
Case 0
strPlatform = "Windows " + CStr(intMajor) + "." + CStr(intMinor)
Case 1
strPlatform = "Windows 95"
Case 2
strPlatform = "Windows NT"
End SelectElse
' The call failed, set the values to zero
intMajor = 0
intMinor = 0
strPlatform = ""End IfEnd Sub'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'以下在窗体文件中(*.frm)
Option Explicit' Some variables to obtain the system informationDim Systeem As New System ' Systeem is Dutch for System
Dim Drive As String
Dim Percent As Byte
Dim Free As Long
Dim Total As Long
Dim Processor As String
Dim Number As Long
Dim Active As Long
Dim Maj As Integer
Dim Min As Integer
Dim Version As String
Dim TotalDiskSpace As Long
Dim FreeDiskSpace As Long
Dim ENTER As StringDim Removable As Integer
Dim Fixed As Integer
Dim Ram As Integer
Dim Network As Integer
Dim CDrom As IntegerPrivate Declare Function apiGetDrives Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As LongSub Drives()Dim Retrn As Long
Dim Buffer As Long
Dim Temp As String
Dim intI As Integer
Dim Read(1 To 100) As String
Dim Counter As IntegerBuffer = 10' This first part is copied from the function Drives in the Class system
' so for the explanation, see the Drives function.Again:
Temp = Space$(Buffer)
Retrn = apiGetDrives(Buffer, Temp)If Retrn > Buffer Then
Buffer = Retrn
GoTo Again
End If' The API returns something like :
' A:\*B:\*C:\*D:\** , with * = NULL character
' 1234123412341234
' \ 1 \ 2 \ 3 \ 4 '
' So we start reading three characters, we step 4 further (the three we read + the
' NULL-character), and we read again three characters, step 4, ect.Counter = 0
For intI = 1 To (Buffer - 4) Step 4
Counter = Counter + 1
Read(Counter) = Mid$(Temp, intI, 3) ' Read all the drives into this array
Next ' Now this array contains all the drives
' so we can check them all out.For intI = 1 To Counter
' Change the Drive to all the drives we have stored in the array.
' Now we can show information about all the drives in your computer.
Drive = Read(intI)
Systeem.DriveInfo Drive, TotalDiskSpace, FreeDiskSpace
If TotalDiskSpace = 0 Then
'No disk was loaded! Show nothing
Text1.Text = Text1.Text + ENTER + "Disk " + Drive + " :" + ENTER
Text1.Text = Text1.Text + "Drive Type = " + Systeem.DriveType(Drive) + ENTER
Text1.Text = Text1.Text + "Total disk space = No disk loaded" + ENTER
Text1.Text = Text1.Text + "Free disk space = -" + ENTER
Text1.Text = Text1.Text + "Volumelabel = -" + ENTER
Text1.Text = Text1.Text + "Serial Number = -" + ENTER
Else
' If a disk was loaded, show all the information.
Text1.Text = Text1.Text + ENTER + "Disk " + Drive + " :" + ENTER
Text1.Text = Text1.Text + "Drive Type = " + Systeem.DriveType(Drive) + ENTER
Text1.Text = Text1.Text + "Total disk space = " + Systeem.PutPoints(TotalDiskSpace) + "KB" + ENTER
Text1.Text = Text1.Text + "Free disk space = " + Systeem.PutPoints(FreeDiskSpace) + " KB" + ENTER
Text1.Text = Text1.Text + "Volumelabel = " + Systeem.VolumeLabel(Drive) + ENTER
Text1.Text = Text1.Text + "Serial Number = " + Systeem.SerialNumber(Drive) + ENTER
End IfNextEnd Sub
Private Sub Form_Load()
'====================================================================
ENTER = Chr$(13) + Chr$(10)
' Call some of the function that return values in variables
Systeem.FreeMemory Percent, Total, Free
Systeem.SystemInfo Processor, Number, Active
Systeem.Drives Removable, Fixed, CDrom, Ram, Network
Systeem.WinVer Maj, Min, Version' Cstr convert values into a string
Text1.Text = ""Text1.Text = Text1.Text + "Operating System = " + Version + ENTER
Text1.Text = Text1.Text + "Windows version = " + CStr(Maj) + "." + CStr(Min) + ENTER
Text1.Text = Text1.Text + "User name = " + Systeem.UserName + ENTERText1.Text = Text1.Text + "Windows Directory = " + Systeem.WinDir + ENTER
Text1.Text = Text1.Text + "System Directory = " + Systeem.SystemDir + ENTER
Text1.Text = Text1.Text + "Temp Directory = " + Systeem.TempDir + ENTERText1.Text = Text1.Text + "Keyboard Type = " + Systeem.KeyboardType + ENTER
Text1.Text = Text1.Text + "Functionkeys = " + CStr(Systeem.FunctionKeys) + ENTERText1.Text = Text1.Text + "Computername = " + Systeem.ComputerName + ENTER
Text1.Text = Text1.Text + "Number of Processors = " + CStr(Number) + ENTER
Text1.Text = Text1.Text + "Active Processor = #" + CStr(Active) + ENTER
Text1.Text = Text1.Text + "Processor Type = " + Processor + ENTER
Text1.Text = Text1.Text + "Total RAM = " + CStr(Total) + " Kb" + ENTER
Text1.Text = Text1.Text + "Free RAM = " + CStr(Free) + " Kb" + ENTER
Text1.Text = Text1.Text + "RAM used = " + CStr(Percent) + " %" + ENTER + ENTER
Text1.Text = Text1.Text + "Removable drives = " + CStr(Removable) + ENTER
Text1.Text = Text1.Text + "Fixed drives = " + CStr(Fixed) + ENTER
Text1.Text = Text1.Text + "CD-ROM drives = " + CStr(CDrom) + ENTER
Text1.Text = Text1.Text + "RAM drives = " + CStr(Ram) + ENTER
Text1.Text = Text1.Text + "Network drives = " + CStr(Network) + ENTER' Call the sub Drives (this is a sub of this form, not of the class)
Drives
End Sub
'以下在类模块中： (system.cls)
Option Explicit
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------'---------------------------------------------------------------------------
' API declarations in order to obtain names (computer and user names)
'---------------------------------------------------------------------------
Private Declare Function apiUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function apiCompName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'---------------------------------------------------------------------------
' API declarations in order to obtain the Windows / System and Temporary
' directories.
'---------------------------------------------------------------------------
Private Declare Function apiWindDir Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function apiSysDir Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function apiTempDir Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'---------------------------------------------------------------------------
' API declarations in order to obtain Memory and System information.
'---------------------------------------------------------------------------
Private Declare Sub apiMemStatus Lib "kernel32" Alias "GlobalMemoryStatus" (lpBuffer As MEMORYSTATUS)
Private Type MEMORYSTATUS ' size of 'Type' = 8 x 4 bytes = 32 (a Long is 4 Bytes)
dwLength As Long ' This need to be set at the size of this 'Type' = 32
dwMemoryLoad As Long ' Gives global indication of used RAM (in %)
dwTotalPhys As Long ' Gives total RAM of the computer
dwAvailPhys As Long ' Gives the amount of free RAM
dwTotalPageFile As Long ' I don't use this (don't know what it means)
dwAvailPageFile As Long ' I don't use this (don't know what it means)
dwTotalVirtual As Long ' I don't use this (don't know what it means)
dwAvailVirtual As Long ' I don't use this (don't know what it means)
End TypePrivate Declare Sub apiSystemInfo Lib "kernel32" Alias "GetSystemInfo" (lpSystemInfo As SYSTEM_INFO)
Private Type SYSTEM_INFO ' size of 'Type' = 9 x 4 bytes = 36
dwOemID As Long
dwPageSize As Long ' Must be set at the size of this 'Type'
lpMinimumApplicationAddress As Long ' ?
lpMaximumApplicationAddress As Long ' ?
dwActiveProcessorMask As Long ' Gives the active processor number
dwNumberOfProcessors As Long ' Gives number of processors
dwProcessorType As Long ' Gives the processor type (386,486,586)
dwAllocationGranularity As Long ' ?
dwReserved As Long ' ?
End Type
'---------------------------------------------------------------------------
' API declaration to get information about the drives.
'---------------------------------------------------------------------------
Private Declare Function apiDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function apiDiskFreeSpace 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 apiFastFreeSpace Lib "STKIT432.DLL" Alias "DISKSPACEFREE" () As Long
Private Declare Function apiGetDrives Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function apiSerialNumber 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 LongPrivate Declare Function apiMonitors Lib "winspool.drv" Alias "EnumMonitorsA" (ByVal pName As String, ByVal Level As Long, pMonitors As Byte, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Type MONITOR_INFO_1
pName As String
End Type
Private Type MONITOR_INFO_2
pName As String
pEnvironment As String
pDLLName As String
End Type'---------------------------------------------------------------------------
' API declarations to obtain the Windows version and the type of
' keyboard.
'---------------------------------------------------------------------------
Private Declare Function apiGetVersion Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
' size of 'Type' = (5 x 4 bytes) = 20 bytes (the 5 Longs)
' 128 bytes (fixed-length string)
' ----- +
' 148 bytes
dwOSVersionInfoSize As Long ' Has to be set to size of 'type'= 148
dwMajorVersion As Long ' Gives the Major version
dwMinorVersion As Long ' Gives the Minor version
dwBuildNumber As Long ' Gives the buildnumber (I don't use it)
dwPlatformId As Long ' Gives the operating system.
szCSDVersion As String * 128 ' ?
End TypePrivate Declare Function apiKeyboardType Lib "user32" Alias "GetKeyboardType" (ByVal nTypeFlag As Long) As LongPublic Sub DriveInfo(ByVal strRoot As String, ByRef lngTotalSpace As Long, ByRef lngFreeSpace As Long)
'---------------------------------------------------------------------------
' SUB: DriveInfo
'
' This Sub returns the amount of total disk space and free disk space. The
' API call return the number of Clusters, Free Clusters, Sectors per cluster,
' and Bytes per cluster. By multiplying these values you can get the
' required information.
'
' lngTotalSpace and lngFreeSpace give the amount of space in BYTES!
' (see PutPoints)
'
' IN: strRoot - String containing the root of the drive you want to
' check. (e.g. "A:\", or "C:\")
'
' OUT: lngTotalSpace - Long containing the total disk space of the drive.
' lngFreeSpace - Long containing the amount of free disk space.
'
' If the API call fails, Zero is returned in both variables.
'---------------------------------------------------------------------------
'
Dim TotalClusters As Long
Dim FreeClusters As Long
Dim SectorsPerCluster As Long
Dim BytesPerSector As LongIf apiDiskFreeSpace(strRoot, SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) Then
' If the call succeeds return the asked amount of diskspace.
lngTotalSpace = SectorsPerCluster * BytesPerSector * (TotalClusters \ 1024)
lngFreeSpace = SectorsPerCluster * BytesPerSector * (FreeClusters \ 1024)
Else
' Otherwise return zero.
lngTotalSpace = 0
lngFreeSpace = 0
End IfEnd Sub
Public Sub Drives(ByRef intRemovable As Integer, ByRef intNotRemovable As Integer, ByRef intCD As Integer, ByRef intRAM As Integer, ByRef intNetwork As Integer)
'---------------------------------------------------------------------------
' SUB: Drives
'
' Returns the number of removable, fixed, CD-ROM, RAM, and Network drives
' that are connected to your computer.
'
' THIS FUNCTION USES THE DRIVETYPE FUNCTION, SO IF YOU MODIFY THAT FUNCTION
' YOU MUST ALSO MODIFY THIS FUNCTION.
'
' OUT: intRemovable - Integer containing the number of removable drives
' intNotRemovable - Integer containing the number of fixed drives
' intCD - Integer containing the number of CD drives
' intRAM - Integer containing the number of RAM disks
' int Network - Integer containing the number of Network drives
'
'---------------------------------------------------------------------------
'
Dim Retrn As Long
Dim Buffer As Long
Dim Temp As String
Dim intI As Integer
Dim Read As String
Dim Counter As Integer
Buffer = 10Again:
Temp = Space$(Buffer)
Retrn = apiGetDrives(Buffer, Temp)
' Call the API function.If Retrn > Buffer Then ' If the API returned a value that is bigger than Buffer,
Buffer = Retrn ' than the Buffer isn't big enough to hold the information.
GoTo Again ' In that case adjust the Buffer to the right size (returned by
End If ' the API) and try again.
' The API returns something like :
' A:\*B:\*C:\*D:\** , with * = NULL character
' 1234123412341234
' \ 1 \ 2 \ 3 \ 4 '
' So we start reading three characters, we step 4 further (the three we read + the
' NULL-character), and we read again three characters, step 4, ect.Counter = 0
For intI = 1 To (Buffer - 4) Step 4 Counter = Counter + 1
Read = Mid$(Temp, intI, 3)
Select Case DriveType(Read)
Case "Removable drive"
intRemovable = intRemovable + 1
Case "Fixed drive"
intNotRemovable = intNotRemovable + 1
Case "Network drive"
intNetwork = intNetwork + 1
Case "CD-ROM drive"
intCD = intCD + 1
Case "RAM-disk"
intRAM = intRAM + 1
End SelectNextEnd SubPublic Function DriveType(ByVal strRoot As String) As String
'---------------------------------------------------------------------------
' FUNCTION: DriveType
'
' This function returns information about the drive you asked for. It will
' return whether the drive is a Removable drive, a non-removable (fixed)
' drive, a CD-ROM drive, a RAM drive or a Network drive.
'
' IN: strRoot - String containing the root of a drive. (e.g. "C:\")
'
' OUT: DriveType - String containing type of drive.
'
' If the function fails a empty string is returned.
'
' You can also re-program this Function so that it doens't return a string,
' but it returns the value. That can be easier if you want to work with
' the returned information. I let it return a string, so that I can print
' it.
'
' THE DRIVES FUNCTION USES THIS FUNCTION, SO IF YOU MODIFY THIS FUNCTION,
' YOU ALSO HAVE TO MODIFY THAT FUNCTION!
'
'---------------------------------------------------------------------------
'
Dim lngType As Long
Const DRIVE_CDROM = 5 ' Some API constants required to
Const DRIVE_FIXED = 3 ' get the difference between the
Const DRIVE_RAMDISK = 6 ' drive types.
Const DRIVE_REMOTE = 4
Const DRIVE_REMOVABLE = 2lngType = apiDriveType(strRoot)
' The API returns a value in lngType. Use the Constants to
' make the strings.Select Case lngType
Case DRIVE_REMOVABLE
DriveType = "Removable drive"
Case DRIVE_FIXED
DriveType = "Fixed drive"
Case DRIVE_REMOTE
DriveType = "Network drive"
Case DRIVE_CDROM
DriveType = "CD-ROM drive"
Case DRIVE_RAMDISK
DriveType = "RAM-disk"
Case Else
DriveType = "" ' If the API returns an error, we return a empty string
End SelectEnd Function
Public Function PutPoints(ByVal lngNumber As Long) As String
'---------------------------------------------------------------------------
' FUNCTION: PutPoints
'
' YOU'D BETTER RENAME THIS FUNCTION, BECAUSE I COULDN'T THINK OF A GOOD
' NAME. (I should have used "dots" instead of "points".....)
'
' This function makes the values returned by the DriveInfo (lngTotalSpace and
' lngFreeSpace) more readable. It put dot (.) in the number.
' (hmmm... how can I explain this right??)
' e.g. if you pass "1000" in this function it will return "1.000"
' even so: "123456789" --> "123.456.789"
' "1234567" --> "1.234.567"
'
' I don't know if it works perfectly, but up to now I haven't discovered any
' errors.
'
' IN: lngNumber - Long containing the number to be converted.
'
' OUT: PutPoints - String containing the number with dots inserted.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' PLEASE NOTE THAT THIS IS VERY HARD TO EXPLAIN FOR ME IN ENGLISH. I HOPE '
' YOU UNDERSTAND WHAT I AM DOING HERE!! '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' It is also possible to do the following:
' PutPoints = Format(lngNumber, "###.###.###.###.###.###")
'
' But I have noticed that when you pass zero to this format function, it
' returns an empty string!
'
'---------------------------------------------------------------------------
'
Dim NumOfPlaces As Integer
Dim Counter As Integer
Dim CurValue As String
Dim Remainder As LongIf Len(lngNumber) > 3 Then ' Check if the number is > 999, otherwise you don't need
' putting dots in it.
NumOfPlaces = Len(CStr(lngNumber)) \ 3
' Count the number of dot that must be inserted. Divide the lngNumber by three
' to obtain this. Note that I use the "\" to divide. I only want the value before
' the dot. (in other words: I don't want decimals (not 1.23233, but 1))
If NumOfPlaces = Len(CStr(lngNumber)) / 3 Then ' I the number is exactly dividable by
NumOfPlaces = NumOfPlaces - 1 ' three, one dot less is needed.
End If ' e.g. 111000 requires only one dot
' and not two.
For Counter = 0 To NumOfPlaces - 1
' Read the last three numbers in lngNumber and add a dot before it. Then read the next
' three numbers (with a dot before it) and add the part of the first time behind it.
PutPoints = "." + CStr(Mid$(lngNumber, Len(CStr(lngNumber)) - ((Counter * 3) + 2), 3)) + CurValue
CurValue = PutPoints ' Store the part we already have in CurValue
Next
Remainder = Len(CStr(lngNumber)) - (((Counter - 1) * 3) + 2) - 1
PutPoints = CStr(Left$(lngNumber, Remainder)) + CurValue
' Read the last numbers that must be before the first dot and add it to the PutPoint
' and then return it.Else
' I the number doens't need any dots, return the unaltered number.
PutPoints = lngNumberEnd If
End Function
Public Function FastDiskSpace(ByVal strRoot As String) As Long
'---------------------------------------------------------------------------
' FUNCTION: FastDiskSpace
'
' Returns the amount of free disk space. See also the DriveInfo function.
' This function is faster because here we don't have to multiply some
' values in order to get the diskspace.
'
' The amount of free space is given in BYTES! (See PutPoints)
'
' IN: strRoot - String containing the root of the drive you want to
' check out.
'
' OUT: FastDiskSpace - Long containing the amount of free space (in bytes)
'---------------------------------------------------------------------------
'
Dim strCurrent As String
On Error GoTo Bliep '(Dutch variation of Beep, means an error)strCurrent = CurDir ' Save the current drive
ChDrive strRoot ' Change to the requested driveFastDiskSpace = apiFastFreeSpace 'Get the free spaceChDrive Left$(strCurrent, 2) ' Return to the saved drive
ChDir strCurrent ' Return to the saved directoryExit FunctionBliep:
' If the drive wasn't ready or something
FastDiskSpace = 0 ' Return zero as free disk space
ChDrive Left$(strCurrent, 2) ' Retur to the saved drive
ChDir strCurrent ' and directoryEnd FunctionPublic Sub FreeMemory(ByRef btePercentUsed As Byte, ByRef lngTotalRam As Long, ByRef lngFreeRam As Long)
'---------------------------------------------------------------------------
' SUB: FreeMemory
'
' Returns information about your RAM (-memory).
' lngTotalRam en lngFreeRam return the amount of RAM in Kbytes!
'
' OUT: btePercentUsed - Byte that gives an indication of used RAM in %
' lngTotalRam - Long containing the amount of total RAM
' lngFreeRam - Long containing the aomunt of free RAM
'---------------------------------------------------------------------------
'
Dim Memory As MEMORYSTATUSMemory.dwLength = 32
' This must be set to the size of the structure before the callapiMemStatus Memory
' Call the API. This function fills the Memory structure (Type) with
' a lot of information. I only use three parts of it.' Fill the variables with the desired values.
btePercentUsed = Memory.dwMemoryLoad
lngTotalRam = Memory.dwTotalPhys / 1024
lngFreeRam = Memory.dwAvailPhys / 1024End Sub
Public Function FunctionKeys() As Byte
'---------------------------------------------------------------------------
' FUNCTION: FunctionKeys
'
' Returns the number of function keys your keyboard has.
' See the KeyboardType function for more information about your keyboard.
'---------------------------------------------------------------------------
'
FunctionKeys = apiKeyboardType(2)End Function
Public Function KeyboardType() As String
'---------------------------------------------------------------------------
' FUNCTION: KeyboardType
'
' Returns a string containing the type of Keyboard you use.
'
'---------------------------------------------------------------------------
'
Dim intBuffer As LongintBuffer = apiKeyboardType(0)
' Call the API. The zero specifies that I want to get information
' about the keyboard type. The FunctionKeys function uses the
' same API call, only with a "2" specified.
' These are all constants I've found somewhere, so I can't explain
' it. It's just true.
Select Case intBuffer
Case 1
KeyboardType = "IBM PC/XT or compatible (83 key)"
Case 2
KeyboardType = "Olivetti ""ico"" (102 key)"
Case 3
KeyboardType = "IBM PC/AT or compatible (84 key)"
Case 4
KeyboardType = "IBM enhanced (101 or 102 key)"
Case 5
KeyboardType = "Nokia 1050 or compatible"
Case 6
KeyboardType = "Nokia 9140 or compatible"
Case 7
KeyboardType = "Japanese"
End SelectEnd Function
Public Sub SystemInfo(ByRef strProcessor As String, ByRef lngNumOfProcessors As Long, ByRef lngActiveProcessor As Long)
'---------------------------------------------------------------------------
' SUB: SystemInfo
'
' This Sub returns the number of processors, the active processor and
' the type of the processor.
'
' OUT: strProcessor - String containing the type of processor.
' lngNumOfProcessors - Long containing the number of processors.
' lngActiveProcessor - Long containing the number of the active
' processor (mostly 1)
'---------------------------------------------------------------------------
'
Dim SI As SYSTEM_INFOapiSystemInfo SI
' The API call fills the SI type with a lot of information
' but I only use three parts of it.
lngActiveProcessor = SI.dwActiveProcessorMask
lngNumOfProcessors = SI.dwNumberOfProcessorsSelect Case SI.dwProcessorType
Case 386
strProcessor = "80386" ' Return the processor type.
Case 486 ' Windows 95 only recognises
strProcessor = "80486" ' these three.
Case 586
strProcessor = "Intel Pentium"
End Select
End Sub
Public Function TempDir() As String
'---------------------------------------------------------------------------
' FUNCTION: TempDir
'
' Get the Temporary directory windows uses.
'
' OUT: TempDir - String containing the directory.
'
' If the function fails a empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API and remove the spaces using RTrim. Next, remove the terminating
' character using StripTerminator, and add a backslash, when if it wasn't
' already there.
'---------------------------------------------------------------------------
If apiTempDir(50, Bufstr) > 0 Then
TempDir = Bufstr
TempDir = RTrim(TempDir)
TempDir = StripTerminator(TempDir)
If Right$(TempDir, 1) <> "\" Then
TempDir = TempDir + "\"
End If
Else
TempDir = ""
End If
End Function
Public Function SystemDir() As String
'---------------------------------------------------------------------------
' FUNCTION: SystemDir
'
' Gets the WINDOWS\SYSTEM directory.
'
' Returns a string containing the full path, ends with a "\". If the
' call fails a empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API and remove the spaces using RTrim. Remove the terminating
' character and add a backslash when it isn't already there.
'---------------------------------------------------------------------------
If apiSysDir(Bufstr, 50) > 0 Then
SystemDir = Bufstr
SystemDir = RTrim(SystemDir)
SystemDir = StripTerminator(SystemDir)
If Right$(SystemDir, 1) <> "\" Then
SystemDir = SystemDir + "\"
End If
Else
SystemDir = ""
End If
End Function
Public Function ComputerName() As String
'---------------------------------------------------------------------------
' FUNCTION: ComputerName
'
' This function retrieves the Computer name (is the computer is connected to
' a network) and removes the terminating character that the Windows API
' returns.
'
' OUT: ComputerName - String containing the name of the computer. If the
' API call fails, an empty string is returned.
'
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API and remove the empty spaces behind the name using RTrim.
' Afterwards remove the terminating character.
'---------------------------------------------------------------------------
If apiCompName(Bufstr, 50) > 0 Then
ComputerName = Bufstr
ComputerName = RTrim(ComputerName)
ComputerName = StripTerminator(ComputerName)
Else
ComputerName = ""
End If
End Function
Private Function StripTerminator(ByVal strString As String) As String
'---------------------------------------------------------------------------
' FUNCTION: StripTerminator
'
' Returns a string without any zero terminator. Typically,
' this was a string returned by a Windows API call.
'
' IN: [strString] - String to remove terminator from
'
' Returns: The value of the string passed in minus any
' terminating zero.
'
'
' THIS FUNCTION I GOT FROM THE SETUP PROJECT THAT CAME WITH VISUAL BASIC 4.
'---------------------------------------------------------------------------
'
Dim intZeroPos As Integer intZeroPos = InStr(strString, Chr$(0))
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
StripTerminator = strString
End IfEnd Function
Public Function UserName() As String
'---------------------------------------------------------------------------
' FUNCTION: UserName
'
' Get the name of the user.
'
' OUT: UserName - String containing the name of the user of the computer.
'
' If the function fails, an empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API, remove the spaces using RTrim, remove the NULL-character
' using StripTerminator.
'---------------------------------------------------------------------------
If apiUserName(Bufstr, 50) > 0 Then
UserName = Bufstr
UserName = RTrim(UserName)
UserName = StripTerminator(UserName)
Else
UserName = ""
End If
End Function
Public Function SerialNumber(ByVal strRoot As String) As String
'---------------------------------------------------------------------------
' FUNCTION: SerialNumber
'
' Returns the serial number of a drive. It returns the number exactly the
' same as DOS does (hexadecimal value e.g. : 1104-224E)
'
' IN: strRoot - String containing the root of a drive (e.g. "A:\").
'
' OUT: SerialNumber - String containing the serial number.
'
' If the function fails (because the drive wasn't ready or something), the
' function returns "0000-0000" as the serial number.
'
'---------------------------------------------------------------------------
'
Dim VolLabel As String
Dim VolSize As Long
Dim SerNum As Long
Dim MaxLen As Long
Dim Flags As Long
Dim Name As String
Dim NameSize As Long
Dim Check As StringIf apiSerialNumber(strRoot, VolLabel, VolSize, SerNum, MaxLen, Flags, Name, NameSize) Then
' This function returns a lot more, but I can get that information via another function. Check = Format(Hex(SerNum), "00000000")
' Make sure that the length = 8. So convert "123456" to "00123456"
SerialNumber = Left$(Check, 4) + "-" + Right$(Check, 4)
' Split the number in two parts of four and add a "-" between them.Else
' Return "0000-0000" is the function fails.
SerialNumber = "0000-0000"End IfEnd FunctionPublic Function VolumeLabel(ByVal strRoot As String) As String
'---------------------------------------------------------------------------
' FUNCTION: VolumeLabel
'
' Returns the VolumeLabel of a drive. This function doesn't need an API
' Call, because the Visual Basic command "Dir" returns this label.
'
' IN: strRoot - String containing the root of the drive you want
' the Volume Label of.
'
' OUT: VolumeLabel - String containing the Volume Label.
'
' If the function fails an empty string is returned. When the drive hasn't
' got a name, "NoName" is returned as the Volume label.
'---------------------------------------------------------------------------
'
On Error GoTo FurtherVolumeLabel = Dir(strRoot, vbVolume)
VolumeLabel = StripTerminator(VolumeLabel)
' Get the volume label and remove the NULL character.If VolumeLabel = "" Then VolumeLabel = "NoName"
' Set the label to "NoName", when the drive hasn't got a name.Exit Function
Further:
VolumeLabel = ""
' If the function fails, return an empty string.End FunctionPublic Function WinDir() As String
'---------------------------------------------------------------------------
' FUNCTION: WinDir
'
' Returns the Windows directory (Mostly "C:\WINDOWS\")
'
' If the function fails an empty string is returned.
'---------------------------------------------------------------------------
'
Dim Bufstr As String
Bufstr = Space$(50)
'---------------------------------------------------------------------------
' Call the API, remove the extra spaces using RTrim, remove the NULL-character
' using StripTerminator, and add a backslash.
'---------------------------------------------------------------------------
If apiWindDir(Bufstr, 50) > 0 Then
WinDir = Bufstr
WinDir = RTrim(WinDir)
WinDir = StripTerminator(WinDir)
If Right$(WinDir, 1) <> "\" Then
WinDir = WinDir + "\"
End If
Else
WinDir = ""
End If
End Function
Public Sub WinVer(ByRef intMajor As Integer, ByRef intMinor As Integer, ByRef strPlatform As String)
'---------------------------------------------------------------------------
' SUB: WinVer
'
' This sub returns information about the operating system, and about
' the Windows Version.
'
' e.g. Windows 3.11
' The sub will return:
' - intMajor = 3
' - intMinor = 11
' - strPlatform = Windows 3.11
'
' OUT: intMajor - Integer containing the major version of Windows.
' intMinor - Integer containing the minor version of windows.
'
' strPlatfrom returns one of the following :
' Windows 95
' Windows NT
' Windows + Version
'
' If the call fails intMajor = 0, intMinor = 0, and strPlatform = ""
'---------------------------------------------------------------------------
'
Dim OSystem As OSVERSIONINFOOSystem.dwOSVersionInfoSize = 148
' The size of the structure must be set before the call.If apiGetVersion(OSystem) Then
' Call the API. It fills the OSystem type. intMajor = OSystem.dwMajorVersion ' Store the Major version in intMajor
intMinor = OSystem.dwMinorVersion ' Store the Minor version in intMinor
Select Case OSystem.dwPlatformId ' Set strPlatform
Case 0
strPlatform = "Windows " + CStr(intMajor) + "." + CStr(intMinor)
Case 1
strPlatform = "Windows 95"
Case 2
strPlatform = "Windows NT"
End SelectElse
' The call failed, set the values to zero
intMajor = 0
intMinor = 0
strPlatform = ""End IfEnd Sub'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'以下在窗体文件中(*.frm)
Option Explicit' Some variables to obtain the system informationDim Systeem As New System ' Systeem is Dutch for System
Dim Drive As String
Dim Percent As Byte
Dim Free As Long
Dim Total As Long
Dim Processor As String
Dim Number As Long
Dim Active As Long
Dim Maj As Integer
Dim Min As Integer
Dim Version As String
Dim TotalDiskSpace As Long
Dim FreeDiskSpace As Long
Dim ENTER As StringDim Removable As Integer
Dim Fixed As Integer
Dim Ram As Integer
Dim Network As Integer
Dim CDrom As IntegerPrivate Declare Function apiGetDrives Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As LongSub Drives()Dim Retrn As Long
Dim Buffer As Long
Dim Temp As String
Dim intI As Integer
Dim Read(1 To 100) As String
Dim Counter As IntegerBuffer = 10' This first part is copied from the function Drives in the Class system
' so for the explanation, see the Drives function.Again:
Temp = Space$(Buffer)
Retrn = apiGetDrives(Buffer, Temp)If Retrn > Buffer Then
Buffer = Retrn
GoTo Again
End If' The API returns something like :
' A:\*B:\*C:\*D:\** , with * = NULL character
' 1234123412341234
' \ 1 \ 2 \ 3 \ 4 '
' So we start reading three characters, we step 4 further (the three we read + the
' NULL-character), and we read again three characters, step 4, ect.Counter = 0
For intI = 1 To (Buffer - 4) Step 4
Counter = Counter + 1
Read(Counter) = Mid$(Temp, intI, 3) ' Read all the drives into this array
Next ' Now this array contains all the drives
' so we can check them all out.For intI = 1 To Counter
' Change the Drive to all the drives we have stored in the array.
' Now we can show information about all the drives in your computer.
Drive = Read(intI)
Systeem.DriveInfo Drive, TotalDiskSpace, FreeDiskSpace
If TotalDiskSpace = 0 Then
'No disk was loaded! Show nothing
Text1.Text = Text1.Text + ENTER + "Disk " + Drive + " :" + ENTER
Text1.Text = Text1.Text + "Drive Type = " + Systeem.DriveType(Drive) + ENTER
Text1.Text = Text1.Text + "Total disk space = No disk loaded" + ENTER
Text1.Text = Text1.Text + "Free disk space = -" + ENTER
Text1.Text = Text1.Text + "Volumelabel = -" + ENTER
Text1.Text = Text1.Text + "Serial Number = -" + ENTER
Else
' If a disk was loaded, show all the information.
Text1.Text = Text1.Text + ENTER + "Disk " + Drive + " :" + ENTER
Text1.Text = Text1.Text + "Drive Type = " + Systeem.DriveType(Drive) + ENTER
Text1.Text = Text1.Text + "Total disk space = " + Systeem.PutPoints(TotalDiskSpace) + "KB" + ENTER
Text1.Text = Text1.Text + "Free disk space = " + Systeem.PutPoints(FreeDiskSpace) + " KB" + ENTER
Text1.Text = Text1.Text + "Volumelabel = " + Systeem.VolumeLabel(Drive) + ENTER
Text1.Text = Text1.Text + "Serial Number = " + Systeem.SerialNumber(Drive) + ENTER
End IfNextEnd Sub
Private Sub Form_Load()
'====================================================================
ENTER = Chr$(13) + Chr$(10)
' Call some of the function that return values in variables
Systeem.FreeMemory Percent, Total, Free
Systeem.SystemInfo Processor, Number, Active
Systeem.Drives Removable, Fixed, CDrom, Ram, Network
Systeem.WinVer Maj, Min, Version' Cstr convert values into a string
Text1.Text = ""Text1.Text = Text1.Text + "Operating System = " + Version + ENTER
Text1.Text = Text1.Text + "Windows version = " + CStr(Maj) + "." + CStr(Min) + ENTER
Text1.Text = Text1.Text + "User name = " + Systeem.UserName + ENTERText1.Text = Text1.Text + "Windows Directory = " + Systeem.WinDir + ENTER
Text1.Text = Text1.Text + "System Directory = " + Systeem.SystemDir + ENTER
Text1.Text = Text1.Text + "Temp Directory = " + Systeem.TempDir + ENTERText1.Text = Text1.Text + "Keyboard Type = " + Systeem.KeyboardType + ENTER
Text1.Text = Text1.Text + "Functionkeys = " + CStr(Systeem.FunctionKeys) + ENTERText1.Text = Text1.Text + "Computername = " + Systeem.ComputerName + ENTER
Text1.Text = Text1.Text + "Number of Processors = " + CStr(Number) + ENTER
Text1.Text = Text1.Text + "Active Processor = #" + CStr(Active) + ENTER
Text1.Text = Text1.Text + "Processor Type = " + Processor + ENTER
Text1.Text = Text1.Text + "Total RAM = " + CStr(Total) + " Kb" + ENTER
Text1.Text = Text1.Text + "Free RAM = " + CStr(Free) + " Kb" + ENTER
Text1.Text = Text1.Text + "RAM used = " + CStr(Percent) + " %" + ENTER + ENTER
Text1.Text = Text1.Text + "Removable drives = " + CStr(Removable) + ENTER
Text1.Text = Text1.Text + "Fixed drives = " + CStr(Fixed) + ENTER
Text1.Text = Text1.Text + "CD-ROM drives = " + CStr(CDrom) + ENTER
Text1.Text = Text1.Text + "RAM drives = " + CStr(Ram) + ENTER
Text1.Text = Text1.Text + "Network drives = " + CStr(Network) + ENTER' Call the sub Drives (this is a sub of this form, not of the class)
Drives
End Sub
解决方案 »
免费领取超大流量手机卡，每月29元包185G流量+100分钟通话, 中国电信官方发货