system.cls

大量优秀的vb编程

lngFreeRam = Memory.dwAvailPhys / 1024

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

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

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

apiSystemInfo 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.dwNumberOfProcessors

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

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

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

OSystem.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 Select

Else
' The call failed, set the values to zero
    intMajor = 0
    intMinor = 0
    strPlatform = ""

End If

End Sub