apisysteminfo.cls

几个不错的VB例子

    SPIF_NOUPDATE = &H0
    SPIF_UPDATEINIFILE = &H1
    SPIF_SENDWININICHANGE = &H2
End Enum
Public SystemWideUpdate As SystemParametersUpdateFlags

Public Property Get CurrentHardwareProfile() As ApiHardwareProfile

Dim pThis As ApiHardwareProfile

Set pThis = New ApiHardwareProfile

Set CurrentHardwareProfile = pThis

Set pThis = Nothing

End Property

Public Property Get GraphicalDeviceInterface() As ApiGraphicalDeviceInterface

Dim gdi As ApiGraphicalDeviceInterface

Set gdi = New ApiGraphicalDeviceInterface

Set GraphicalDeviceInterface = gdi

End Property

Public Property Get InstalledLocales() As Collection

Call APICallbackProcs.RefreshInstalledLocales
Set InstalledLocales = AllInstalledLocales

End Property

Private Function LargeIntToCurrency(liInput As LARGE_INTEGER) As Currency
    'copy 8 bytes from the large integer to an ampty currency
    CopyMemory LargeIntToCurrency, liInput, LenB(liInput)
    'adjust it
    LargeIntToCurrency = LargeIntToCurrency * 10000
End Function
Public Property Let ComputerName(ByVal newname As String)

Dim lret As Long

If LenB(newname) > (MAX_COMPUTERNAME_LENGTH) Then
    ReportError 0, "ApiSystem:ComputerName", "Computer length exceeds MAX_COMPUTERNAME_LEMGTH"
    Exit Property
End If

lret = SetComputername(newname)
If Err.LastDllError <> 0 Then
    ReportError Err.LastDllError, "ApiSystem:ComputerName", GetLastSystemError
End If

End Property

Public Property Get ComputerName() As String

    Dim sTmp As String
    Dim lret As Long
    
    sTmp = String(MAX_COMPUTERNAME_LENGTH, 0)
    lret = GetComputername(sTmp, Len(sTmp))
    If Err.LastDllError <> 0 And Err.LastDllError <> 203 Then
        ReportError Err.LastDllError, "ApiSystem:ComputerName", GetLastSystemError
    Else
        ComputerName = Left$(sTmp, InStr(sTmp, Chr$(0)) - 1)
    End If
    
End Property


'\\ --[IsRequiredSystem]- - - - - - - - - - - - - - - - - - - - - - - - - - - -
'\\ Returns TRUE if the OS is at or above the level required by the function,
'\\ or raises a meaningful error if it isn't
'\\ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - -
Friend Function IsRequiredSystem(ByVal AttemptedFunction As String, _
                                 ByVal RequiredVersion As WindowsOSVersions) As Boolean



    If (Me.WindowsOSVersion >= RequiredVersion) Then
        IsRequiredSystem = True
    Else
        IsRequiredSystem = False
        ReportError 0, "Api Function - " & AttemptedFunction, "The function requires a different version of windows that you have installed"
    End If


End Function


Public Property Get Metrics(ByVal index As SystemMetricsIndexes) As Long

    Metrics = GetSystemMetrics(index)
    If Err.LastDllError Then
        ReportError Err.LastDllError, "ApiSystem:Metrics (Get)", GetLastSystemError
    End If
    
End Property

Public Property Get PerformanceCounter() As Currency

Dim lret As Long
Dim lCounter As LARGE_INTEGER

lret = QueryPerformanceCounter(lCounter)
If Err.LastDllError <> 0 Then
    ReportError Err.LastDllError, "ApiSystem:PerformanceCounter", GetLastSystemError
Else
    PerformanceCounter = LargeIntToCurrency(lCounter)
End If

End Property

Public Property Get PerformanceFrequency() As Currency

Dim lret As Long
Dim lFrequency As LARGE_INTEGER

lret = QueryPerformanceFrequency(lFrequency)
If Err.LastDllError <> 0 Then
    ReportError Err.LastDllError, "ApiSystem:PerformanceFrequency", GetLastSystemError
Else
    PerformanceFrequency = LargeIntToCurrency(lFrequency)
End If

End Property

Public Property Get InstalledPrinters() As Collection

Dim printerthis As ApiPrinter
Dim vbPrint As Printer
Dim colPrinters As Collection

If Printers.Count > 0 Then
    Set colPrinters = New Collection
End If

For Each vbPrint In Printers
    Set printerthis = New ApiPrinter
    printerthis.DeviceName = vbPrint.DeviceName
    colPrinters.Add printerthis, vbPrint.DeviceName
Next vbPrint

Set InstalledPrinters = colPrinters

End Property

Public Property Get ProcessorAlphaByteInstructions() As Boolean

If IsRequiredSystem("Processor.AlphaByteInstructions", ver_win_nt4) Then
    ProcessorAlphaByteInstructions = IsProcessorFeaturePresent(PF_ALPHA_BYTE_INSTRUCTIONS)
End If

End Property

Public Property Get ProcessorArchitecture() As ProcessorArchitectures

    'processorarchitecture = msysinfo.p
End Property

Public Property Get ProcessorCompareExchangeDouble() As Boolean

If IsRequiredSystem("Processor.CompareExchangeDouble", ver_win_nt4) Then
    ProcessorCompareExchangeDouble = IsProcessorFeaturePresent(PF_COMPARE_EXCHANGE_DOUBLE)
End If

End Property

Public Property Get ProcessorCount() As Long

    ProcessorCount = mSysInfo.NumberOfProcessors
    
End Property

Public Property Get ProcessorFloatingPointEmulation() As Boolean

If IsRequiredSystem("Processor.FloatingPointEmulation", ver_win_nt4) Then
    ProcessorFloatingPointEmulation = IsProcessorFeaturePresent(PF_FLOATING_POINT_EMULATED)
End If

End Property


Public Property Get ProcessorFloatingPointError() As Boolean

If IsRequiredSystem("Processor.FloatingPointError", ver_win_nt4) Then
    ProcessorFloatingPointError = IsProcessorFeaturePresent(PF_FLOATING_POINT_PRECISION_ERRATA)
End If

End Property

Public Property Get ProcessorLevel() As ProcessorLevels

Select Case True
Case ProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL
    '\\ Intel (and compatible) processor levels
    Select Case mSysInfo.ProcessorLevel
    Case 3
        ProcessorLevel = PROC_INTEL_80386
    Case 4
        ProcessorLevel = PROC_INTEL_80486
    Case 5
        ProcessorLevel = PROC_INTEL_PENMTIUM
    Case 6
        ProcessorLevel = PROC_INTEL_PENTIUM_PRO
    End Select
    
Case ProcessorArchitecture = PROCESSOR_ARCHITECTURE_ALPHA
    '\\ DEC Alpha chipsets
    Select Case mSysInfo.ProcessorLevel
    Case 21064
        ProcessorLevel = PROC_ALPHA_21064
    Case 21066
        ProcessorLevel = PROC_ALPHA_21066
    Case 21164
        ProcessorLevel = PROC_ALPHA_21164
    End Select

Case ProcessorArchitecture = PROCESSOR_ARCHITECTURE_PPC
    '\\ Power PC chipset architecture
    Select Case mSysInfo.ProcessorLevel
    Case 1  'PPC 601
        ProcessorLevel = PROC_PPC_601
    Case 3  'PPC 603
        ProcessorLevel = PROC_PPC_603
    Case 4  'PPC 604
        ProcessorLevel = PROC_PPC_604
    Case 6  'PPC 603+
        ProcessorLevel = PROC_PPC_603_PLUS
    Case 9  'PPC 604+
        ProcessorLevel = PROC_PPC_604_PLUS
    Case 20 'PPC 620
        ProcessorLevel = PROC_PPC_620
    End Select
    
Case ProcessorArchitecture = PROCESSOR_ARCHITECTURE_MIPS
    '\\ MIPS (or clone) chip
        ProcessorLevel = PROC_MIPS_8400
End Select

End Property

Public Property Get ProcessorMMXInstructions() As Boolean

If IsRequiredSystem("Processor.MMXInstructions", ver_win_nt4) Then
    ProcessorMMXInstructions = IsProcessorFeaturePresent(PF_MMX_INSTRUCTIONS_AVAILABLE)
End If

End Property

Public Property Get ProcessorMoveMem64Bit() As Boolean

If IsRequiredSystem("Processor.MoveMem64Bit", ver_win_nt4) Then
    ProcessorMoveMem64Bit = IsProcessorFeaturePresent(PF_PPC_MOVEMEM_64BIT_OK)
End If

End Property


Public Property Get ProcessorType() As ProcessorTypes

    ProcessorType = mSysInfo.ProcessorType
    
End Property


Public Property Get TopLevelWindows() As Collection

Call RefreshTopLevelWindows

Set TopLevelWindows = AllTopLevelWindows

End Property

'\\ API calls to populate the volume collection....
Public Property Get Volumes() As Collection

Dim colThis As Collection
Dim volThis As ApiVolume
Set colThis = New Collection

If IsRequiredSystem("VolumeFindFirst", ver_Win_Win2000) Then


End If

Set Volumes = colThis


End Property

Public Property Get WindowsOSBuild() As Long

    WindowsOSBuild = mVerInfo.dwBuildNumber
    
End Property

Public Property Get WindowsOSCSDVersion() As String

WindowsOSCSDVersion = mVerInfo.szCSDVersion
End Property

Public Property Get WindowsOSPlatform() As WindowsOSPlatforms

WindowsOSPlatform = mVerInfo.dwPlatformId

End Property

Public Property Get WindowsOSVersion() As WindowsOSVersions

With mVerInfo
    Select Case .dwMajorVersion
    Case 3
        WindowsOSVersion = ver_Win_NT351
    Case 4
        If .dwMinorVersion = 0 Then
            If .dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
                WindowsOSVersion = ver_Win_95
            Else
                WindowsOSVersion = ver_win_nt4
            End If
        ElseIf .dwMinorVersion = 10 Then
            WindowsOSVersion = ver_Win_98
        ElseIf .dwMinorVersion = 90 Then
            WindowsOSVersion = ver_Win_Me
        End If
    Case 5
        If .dwMinorVersion = 0 Then
            WindowsOSVersion = ver_Win_Win2000
        Else
            WindowsOSVersion = ver_win_Whistler
        End If
    End Select
End With

End Property

Private Sub Class_Initialize()

'\\ Get the current version information at startup...
Dim lret As Long
mVerInfo.dwOSVersionInfoSize = Len(mVerInfo)
lret = GetVersionEx(mVerInfo)
If Err.LastDllError <> 0 Then
    ReportError Err.LastDllError, "ApiSystem", GetLastSystemError
End If

'\\ Get the system info at startup...
Call GetSystemInfo(mSysInfo)
If Err.LastDllError <> 0 Then
    ReportError Err.LastDllError, "ApiSystem", GetLastSystemError
End If

End Sub