system.cls

大量优秀的vb编程

' 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
lngFreeRam = Memory.dwAvailPhys / 1024

End Sub
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 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 String

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

End Function

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

VolumeLabel = 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 Function