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

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

Private Declare Function apiKeyboardType Lib "user32" Alias "GetKeyboardType" (ByVal nTypeFlag 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"
'
' 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 Long

If 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 = lngNumber

End 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 drive

FastDiskSpace = apiFastFreeSpace 'Get the free space

ChDrive Left$(strCurrent, 2)     ' Return to the saved drive
ChDir strCurrent                 ' Return to the saved directory

Exit Function

Bliep:
' 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 directory

End Function

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

Memory.dwLength = 32
' This must be set to the size of the structure before the call

apiMemStatus 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