system.cls

大量优秀的vb编程

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "System"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit


'---------------------------------------------------------------------------
' 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 Type

Private 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 Long

Public 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 Long

If apiDiskFreeSpace(strRoot, SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) Then
'   If the call succeeds return the asked amount of diskspace.
    lngTotalSpace = SectorsPerCluster * BytesPerSector * TotalClusters
    lngFreeSpace = SectorsPerCluster * BytesPerSector * FreeClusters
Else
'   Otherwise return zero.
    lngTotalSpace = 0
    lngFreeSpace = 0
End If

End 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 = 10

Again:
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 Select

Next

End Sub

Public 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 = 2

lngType = 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 Select

End 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"
'