Soyez le premier à donner votre avis sur cette source.
Vue 6 201 fois - Téléchargée 606 fois
' 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
26 févr. 2004 à 09:40
et je di merci Scooby
27 nov. 2003 à 22:07
@+
27 nov. 2003 à 19:19
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.
27 nov. 2003 à 16:55
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 @+
27 nov. 2003 à 16:50
Merci d'avance et @+
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.