Donne des informations sur votre système

Soyez le premier à donner votre avis sur cette source.

Vue 6 051 fois - Téléchargée 543 fois

Description

Donne des informations sur votre système

Source / Exemple :


' Form

Private Sub cmdCallFunc_Click(Index As Integer)
    Select Case Index
        Case 0
            lblFuncRet(Index) = CBool(wincpuidsupport())
        Case 1
            lblFuncRet(Index) = ProcessorCount()
        Case 2
            Me.MousePointer = vbHourglass
            lblFuncRet(Index) = cpunormspeed()
            Me.MousePointer = vbDefault
        Case 3
            Me.MousePointer = vbHourglass
            lblFuncRet(Index) = cpurawspeed()
            Me.MousePointer = vbDefault
        Case 4
            lblFuncRet(Index) = GetCPUDescription()
        Case 5
            lblFuncRet(Index) = GetCPUDescriptionString(Verbose:=CBool(chkVerbose.Value))
        Case 6
            lblFuncRet(Index) = GetCPUModel()
        Case 7
            lblFuncRet(Index) = GetCPUType()
        Case 8
            lblFuncRet(Index) = wincpuid()
        Case 9
            lblFuncRet(Index) = CPUHasMMX()
        Case 10
            lblFuncRet(Index) = CPUHasFPU()
        Case 11
            lblFuncRet(Index) = CPUHasTimeStampCounter()
        Case 12
            Dim vs As DLL_VER
            Call GetDllVerString(vs)
            lblFuncRet(Index) = vs.Major & "." & vs.Minor
    End Select
End Sub

Private Sub cmdTimeStamp_Click()
Dim ts As TIME_STAMP
Dim Output As String
Dim i As Long

If GetTimeStampCode(ts) Then
    Output = Hex$(ts.dwHigh)
    Output = Output & " : " & Hex$(ts.dwLow)
    Call lstTimeStamp.AddItem(Output)
Else
    MsgBox "CPU does not have timestamp register"
End If
End Sub

' Module

Public Type TIME_STAMP
    dwLow As Long  'Lower 32-bits of Time Stamp Register value
    dwHigh As Long   'Upper 32-bits of Time Stamp Register value
End Type

Public Type DLL_VER
    Minor As String 'Minor Version
    Major As String 'Major Version
End Type

Private Declare Function wincpuidext Lib "CpuInf32.dll" () As Integer
Private Declare Function wincpufeatures Lib "CpuInf32.dll" () As Long
Private Declare Function winrdtsc Lib "CpuInf32.dll" () As Currency
Private Declare Function getdllversion Lib "CpuInf32.dll" () As Integer
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                                                    (lpvDest As Any, _
                                                    lpvSource As Any, _
                                                    ByVal cbCopy As Long)

'// PUBLIC DECLARES SECTION /////////////////////////////////////
'////////////////////////////////////////////////////////////////

'****************************************************************
'* FUNCTION wincpuidsupport() As Long
'* =================================
'* Wincpuidsupport() tells the caller whether the host processor
'* supports the CPUID opcode or not.
'*
'* Inputs: none
'*
'* Returns:
'*  1 = CPUID opcode is supported
'*  0 = CPUID opcode is not supported
'****************************************************************
Public Declare Function wincpuidsupport Lib "CpuInf32.dll" () As Integer

'****************************************************************
'* FUNCTION wincpuid() As Long
'* ===============
'* This routine uses the standard Intel assembly code to
'* determine what type of processor is in the computer, as
'* described in application note AP-485 (Intel Order #241618).
'* Wincpuid() returns the CPU type as an integer (that is,
'* 2 bytes, a WORD) in the AX register.
'*
'* Returns:
'*  0 = 8086/88
'*  2 = 80286
'*  3 = 80386
'*  4 = 80486
'*  5 = Pentium(R) Processor
'*  6 = PentiumPro(R) Processor
'*  7 or higher = Processor beyond the PentiumPro6(R) Processor
'****************************************************************
Public Declare Function wincpuid Lib "CpuInf32.dll" () As Long
Public Declare Function cpurawspeed Lib "CpuInf32.dll" () As Long
Public Declare Function cpunormspeed Lib "CpuInf32.dll" () As Long
Public Declare Function ProcessorCount Lib "CpuInf32.dll" () As Long

'// PRIVATE FUNCTION SECTION (Not callable outside of this module)
'////////////////////////////////////////////////////////////////
'/***************************************************************
'/ based on a similar function in "Hardcore VB5" by Bruce McKinney
'/ by Ray Mercer
'/ returns:
'/ value of Specified Bit in a bitfield up to 32 bits long
'/ False=bit is not "set"(0)
'/ True=bit is "set"(1)

Private Function GetBit(ByVal iValue As Long, ByVal iBitPos As Integer) As Boolean
    Debug.Assert iBitPos >= 0 And iBitPos <= 31
    Dim BitVal As Long
    
    Select Case iBitPos
        Case 0
            BitVal = &H1&
        Case 1
            BitVal = &H2&
        Case 2
            BitVal = &H4&
        Case 3
            BitVal = &H8&
        Case 4
            BitVal = &H10&
        Case 5
            BitVal = &H20&
        Case 6
            BitVal = &H40&
        Case 7
            BitVal = &H80&
        Case 8
            BitVal = &H100&
        Case 9
            BitVal = &H200&
        Case 10
            BitVal = &H400&
        Case 11
            BitVal = &H800&
        Case 12
            BitVal = &H1000&
        Case 13
            BitVal = &H2000&
        Case 14
            BitVal = &H4000&
        Case 15
            BitVal = &H8000&
        Case 16
            BitVal = &H10000
        Case 17
            BitVal = &H20000
        Case 18
            BitVal = &H40000
        Case 19
            BitVal = &H80000
        Case 20
            BitVal = &H100000
        Case (21)
            BitVal = &H200000
        Case (22)
            BitVal = &H400000
        Case (23)
            BitVal = &H800000
        Case (24)
            BitVal = &H1000000
        Case (25)
            BitVal = &H2000000
        Case (26)
            BitVal = &H4000000
        Case (27)
            BitVal = &H8000000
        Case (28)
            BitVal = &H10000000
        Case (29)
            BitVal = &H20000000
        Case (30)
            BitVal = &H40000000
        Case (31)
            BitVal = &H80000000
    End Select
    
    GetBit = iValue And BitVal
End Function

'// PUBLIC FUNCTION SECTION /////////////////////////////////////
'////////////////////////////////////////////////////////////////

'****************************************************************
'* FUNCTION GetCPUDescription() As Long
'* ==================
'* Returns a value which describes the currently installed CPU
'* according to the chart below:
'*
'* Inputs: none
'*
'* Outputs:
'* Value    Meaning
'* ______________________________________
'* 64, 65   Intel 486
'* 66       Intel 486SX
'* 67       Intel 487, DX2, or OverDrive
'* 68       Intel 486SL
'* 69       Intel 486SX2
'* 71       Write-Back Enhanced Intel DX2
'* 72       Intel DX4 or DX4 OverDrive
'* 328      Intel DX4 OverDrive
'* 81       Pentium (60, 66)
'* 82       Pentium (75, 90, 100, 120, 133, 150, 166, 200)
'* 337      Pentium OverDrive (60, 66)
'* 338      Pentium OverDrive (75, 90, 100, 120, 133)
'* 339      Pentium OverDrive For 486
'* 84       Pentium with MMX (166, 200)
'* 340      Pentium OverDrive with MMX (75, 90, 100, 120, 133)
'* 97       Pentium Pro
'* 99       Pentium II model 3
'* 101      Pentium II model 5 or Celeron
'* 355      reserved for future Pentium Pro OverDrive
'*
'****************************************************************
Public Function GetCPUDescription() As Long
    Dim BitField As Long
    Dim iType As Long
    Dim iFamily As Long
    Dim iModel As Long
    
    iType = GetCPUType()
    iFamily = wincpuid()
    iModel = GetCPUModel()
    
    iType = iType * 256     'shift left 8 bits
    iFamily = iFamily * 16   'shift left 4 bits
    BitField = iType Or iFamily Or iModel 'combine all ten bits
    '10bit Bitfield Definitions
    'Taken from Intel application note AP-485 (Intel Order #241618)
    'TYPE   FAMILY  MODEL
    '00     0100    0000 Intel 486
    '00     0100    0001 Intel 486
    '00     0100    0010 Intel 486SX
    '00     0100    0011 Intel 487, DX2, or OverDrive
    '00     0100    0100 Intel 486SL
    '00     0100    0101 Intel 486SX2
    '00     0100    0111 Write-Back Enhanced Intel DX2
    '00     0100    1000 Intel DX4 or DX4 OverDrive
    '01     0100    1000 Intel DX4 OverDrive
    '00     0101    0001 Pentium (60, 66)
    '00     0101    0010 Pentium (75, 90, 100, 120, 133, 150, 166, 200)
    '01     0101    0001 Pentium OverDrive (60, 66)
    '01     0101    0010 Pentium OverDrive (75, 90, 100, 120, 133)
    '01     0101    0011 Pentium OverDrive For 486
    '00     0101    0100 Pentium with MMX (166, 200)
    '01     0101    0100 Pentium OverDrive with MMX (75, 90, 100, 120, 133)
    '00     0110    0001 Pentium Pro
    '00     0110    0011 Pentium II model 3
    '00     0110    0101 Pentium II model 5 or Celeron
    '01     0110    0011 reserved for future Pentium Pro OverDrive

    GetCPUDescription = BitField

End Function
'****************************************************************
'* FUNCTION GetCPUDescriptionString(Optional ByVal Verbose As Boolean = True) As String
'* ==================
'* Returns a value which describes the currently installed CPU
'* according to the chart below:
'*
'* Inputs:
'*  Verbose      True (Default) = Long Description strings
'*               False = Short Description strings
'* Outputs:
'*  Returns a string containing a description of the currently installed CPU
'*****************************************************************
Public Function GetCPUDescriptionString(Optional ByVal Verbose As Boolean = True) As String
    Dim CPU As Long
    Dim Description As String
    
    CPU = GetCPUDescription()
    
    If Verbose Then
        Select Case CPU
            Case 64, 65
                Description = "Intel 486 Processor"
            Case 66
                Description = "Intel 486SX Processor"
            Case 67
                Description = "Intel 487, DX2, or OverDrive Processor"
            Case 68
                Description = "Intel 486SL Processor"
            Case 69
                Description = "Intel 486SX2 Processor"
            Case 71
                Description = "Write-Back Enhanced Intel DX2 Processor"
            Case 72
                Description = "Intel DX4 or DX4 OverDrive Processor"
            Case 328
                Description = "Intel DX4 OverDrive Processor"
            Case 81
                Description = "Pentium Processor (60, 66)"
            Case 82
                Description = "Pentium Processor (75, 90, 100, 120, 133, 150, 166, 200)"
            Case 337
                Description = "Pentium OverDrive Processor (60, 66)"
            Case 338
                Description = "Pentium OverDrive Processor (75, 90, 100, 120, 133)"
            Case 339
                Description = "Pentium OverDrive Processor For 486-based Systems"
            Case 84
                Description = "Pentium Processor with MMX (166, 200)"
            Case 340
                Description = "Pentium OverDrive Processor with MMX (75, 90, 100, 120, 133)"
            Case 97
                Description = "Pentium Pro Processor"
            Case 99
                Description = "Pentium II Processor (model 3)"
            Case 101
                Description = "Pentium II (model 5) or Celeron Processor"
            Case 355
                Description = "Pentium Pro OverDrive Processor"
            Case Else
                Description = "Processor Type Unknown"
        End Select
    Else
        Select Case CPU
            Case 64 - 69, 71
                Description = "486"
            Case 72, 328
                Description = "486DX4"
            Case 81, 82, 337 - 339
                Description = "Pentium"
            Case 84, 340
                Description = "PentiumMMX"
            Case 97, 355
                Description = "PentiumPro"
            Case 99
                Description = "PentiumII"
            Case 101
                Description = "PentiumII/Celeron"
            Case Else
                Description = "Unknown"
        End Select
    End If
    GetCPUDescriptionString = Description
End Function

'****************************************************************
'* FUNCTION GetCPUModel() As Long
'* =================
'* AX(7:4)   = CPU Model, if the processor supports the CPUID
'*              opcode; zero otherwise
'* Inputs: none
'*
'* Returns:
'* the second-lowest nibble value of the return from wincpuidext()
'* (bits 7-4)
'* current Intel chip models range from 0 to 7
'****************************************************************
Public Function GetCPUModel() As Long

    Dim BitField As Integer
    Dim LowByte As Byte
    
    BitField = wincpuidext()
    'get LowByte of the 32bit return value while masking Lowest Nibble
    LowByte = BitField And &HF0&
    'shift High Nibble to LowNibble
    If LowByte Then 'avoid divide by 0 error
        GetCPUModel = LowByte / 16
    End If

End Function

'****************************************************************
'* FUNCTION GetCPUType() As Long
'* =================
'* AX(13:12) = Processor type (00=Standard OEM CPU, 01=OverDrive,
'*                              10=Dual CPU, 11=Reserved)
'* Inputs: none
'*
'* Returns:
'* 0    = Standard OEM CPU
'* 1    = OverDrive
'* 2    = Dual CPU
'* 3    = Unknown (Reserved)
'****************************************************************
Public Function GetCPUType() As Long

    Dim BitField As Integer
    Dim Bit1 As Boolean
    Dim Bit2 As Boolean
    Dim CPUType As Long
    
    BitField = wincpuidext()
    Bit1 = GetBit(BitField, 13)
    Bit2 = GetBit(BitField, 12)
    
    If Bit1 Then
        If Bit2 Then
            '11 - Reserved
            CPUType = 3
            Else
            '10 - Dual CPU
            CPUType = 2
        End If
    Else
        If Bit2 Then
            '01 - OverDrive
            CPUType = 1
            Else
            '00 - Standard OEM CPU
            CPUType = 0
        End If
    End If
    
    GetCPUType = CPUType
    
End Function

'****************************************************************
'* FUNCTION wincpufeatures() As Long
'* ======================
'* Wincpufeatures() returns the CPU features flags as a DWORD
'* (that is, 32 bits).
'*
'* Inputs: none
'*
'* Returns:
'*   0 = Processor which does not execute the CPUID instruction.
'*          This includes 8086, 8088, 80286, 80386, and some
'*         older 80486 processors.
'*
'* Else
'*   Feature Flags (refer to App Note AP-485 for description).
'*      This DWORD was put into EDX by the CPUID instruction.
'*
'*  Current flag assignment is as follows:
'*
'*      bit31..25   reserved (unknown value)
'*      bit24=1     Fast Floating Point Save And Restore supported
'*      bit23=1     MMX
'*      bits22..18  reserved (unknown value)
'*      bit17=1     36-bit Page Size Extension supported
'*      bit16=1     Page Attribute Table supported
'*      bit15=1     Conditional Move Instruction spported
'*      bit14=1     Machine Check Architecture  (MCG_CAP) supported
'*      bit13=1     Page Global Enable supported
'*      bit12=1     Memory Type Range Registers (MTRR_CAP) supported
'*      bit11=1     Fast System Call (SYSENTER, SYSEXIT) supported
'*      bit10       reserved (unknown value)
'*      bit9=1      CPU contains a local APIC (iPentium-3V)
'*      bit8=1      CMPXCHG8B instruction supported
'*      bit7=1      machine check exception supported
'*      bit6=1      Physical Address Extension supported
'*      bit5=1      iPentium-style MSRs supported
'*      bit4=1      time stamp counter TSC supported
'*      bit3=1      page size extensions supported
'*      bit2=1      I/O breakpoints supported
'*      bit1=1      enhanced virtual 8086 mode supported
'*      bit0=1      CPU contains a floating-point unit (FPU)
'*
'*  Note: New bits will be assigned on future processors... see
'*         processor data books for updated information
'*
'* The following 3 functions call wincpufeatures to call for
'* 3 specific, individual flags which VB programmers might find useful
'****************************************************************
Public Function CPUHasMMX() As Boolean
    'returns True if CPU has MMX
    'and CPU supports CPUID instruction
    Dim BitField As Long
    
    BitField = wincpufeatures()
    If BitField Then 'MMX CPUS should support CPUID Instructions
        CPUHasMMX = GetBit(BitField, 23)
    End If
        
End Function

Public Function CPUHasFPU() As Boolean
    'returns True if CPU has a Floating Point Processor
    'and CPU supports CPUID instruction
    Dim BitField As Long
    
    BitField = wincpufeatures()
    If BitField Then
        CPUHasFPU = GetBit(BitField, 0)
    End If
        
End Function

Public Function CPUHasTimeStampCounter() As Boolean
    'returns True if CPU has a TimeStampCounter register
    'and CPU supports CPUID instruction
    Dim BitField As Long
    
    BitField = wincpufeatures()
    If BitField Then
        CPUHasTimeStampCounter = GetBit(BitField, 4)
    End If
End Function

'****************************************************************
'* Function GetTimeStampCode()as Boolean
'* ============================
'* returns the value in the Time Stamp Counter (if one
'* exists).
'*
'* Inputs:
'*  A UDT of type TIME_STAMP to recieve the 64bit value
'*
'* Returns:
'*   False= CPU does not support the time stamp register
'*
'* Else
'*  Returns True and loads the UDT with the number of clock cycles
'*  since the CPU was powered up or reset. Since VB can't handle
'*  64bit integer values natively (Not even VB6!) we must use
'*  a Currency type,a UDT, CopyMemory(),and VarPtr()
'*  (Can you say "hack"?)
'*
'****************************************************************
Public Function GetTimeStampCode(ts As TIME_STAMP) As Boolean
    Dim curTS As Currency
    
    curTS = winrdtsc()    'retrieve 64bit value as currency
    If curTS Then
        CopyMemory ts.dwHigh, curTS, 4
        CopyMemory ts.dwLow, ByVal VarPtr(curTS) + 4, 4
        GetTimeStampCode = True
    End If
        
End Function

'****************************************************************
'* Function getdllversion()
'* ==============================
'* Getdllversion() returns the Major and minor version of the
'* CPUInf32 DLL.
'*
'* Inputs: none
'*
'* Returns:  Major and Minor version of this DLL.
'*
'*      i.e.    getdllversion() = 0x01 00
'*                    Major Version<--|-->Minor Version
'*
'****************************************************************
Public Sub GetDllVerString(verString As DLL_VER)
    Dim ver As Integer
    Dim tmpRes As Integer
    Dim hi As Byte
    Dim lo As Byte
    
    ver = getdllversion()
    hi = (ver And &HFF00) / &HFF
    lo = ver And &HFF
    
    verString.Major = Format$(hi, "##0")
    verString.Minor = Format$(lo, "##00")

End Sub

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
15
Date d'inscription
mercredi 4 juin 2003
Statut
Membre
Dernière intervention
25 février 2004

ben moi sa ma bien servi
et je di merci Scooby
Messages postés
48
Date d'inscription
dimanche 12 mai 2002
Statut
Membre
Dernière intervention
26 novembre 2003

Merci pour ce commentaire. Désoler je ne m'en souvient plus mais si je la retrouve, je vous en ferais part via un commentaire.

@+
Messages postés
4
Date d'inscription
mercredi 24 septembre 2003
Statut
Membre
Dernière intervention
25 août 2005

Enfin un code propre, commenté, fournissant les informations autrement qu'en allant piocher dans la base de registre où il faut toujours espérer que l'utilisateur du poste n'a pas été changé les valeurs...

La critique d'un code comme celui-ci n'a pas sa place ici. Que ceux qui critiquent fournissent leurs sources aussi proprement !
Enfin, même si le code n'est pas de lui, il a le mérite de vouloir faire progresser les autres en ajoutant un code intéressant plutôt qu'un code pourri comme on en voit malheureusement trop.

Cependant, si Scooby1 (l'initiateur de cette page) se souvenait de l'url où il a trouvé ce code, ça pourrait intéresser de connaître quels sont les sites instructifs.
Messages postés
48
Date d'inscription
dimanche 12 mai 2002
Statut
Membre
Dernière intervention
26 novembre 2003

Correction :

La critique de eyesonlyle ne sert à rien puisse que la réponse a déjà été donnée alors ce qui viennent pour critiquer sont les bienvenues tant que ces critiques sont là pour faire progressées le code sources, sinon aller voir ailleur pour vos conneries. De plus merci de parler Français.

Merci d'avance et @+
Messages postés
48
Date d'inscription
dimanche 12 mai 2002
Statut
Membre
Dernière intervention
26 novembre 2003

la critique de eyesonlyle ne sert à rien puisse que la réponse à déjà été donnée alors ce qui pour critiquer sont les bienvenu tant que ces critiques sont la pour faire progressé le code sources, sinon aller voir ailleur pour vaut connerie.

Merci d'avance et @+
Afficher les 11 commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.