VB6硬件检测

Function QOC(CCS, MCS)
     If CCS = MCS Then
         Set wReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
         wReg.GetDWORDValue &H80000002, "HARDWARE\DESCRIPTION\System\CentralProcessor\0", "~MHz", strValue
         OC = strValue: Set wReg = Nothing
         Else
         OC = CCS
     End If
     QOC = OC: If QOC Mod 2 = 1 Then QOC = QOC + 1
 End Function
 
 Function wDate(nD)
     If Not IsNull(nD) Then
     wDate = CDate(Mid(nD, 5, 2) & "/" & Mid(nD, 7, 2) & "/" & Left(nD, 4) & " " & Mid(nD, 9, 2) & ":" & Mid(nD, 11, 2) & ":" & Mid(nD, 13, 2))
     End If
 End Function
 
 Function JZCS()
     NumMsg = vbCrLf & "———————————简易CPU基准测试———————————" & vbCrLf
     Dim I, T1, T2, Tempvalue, aRunTime, bRunTime
     T1 = Timer()
     For I = 1 To 2000000
         Tempvalue = 2 ^ 0.5
     Next
     T2 = Timer()
     aRunTime = FormatNumber((T2 - T1) * 1000, 2)
     NumMsg = NumMsg & "CPU 200万次开方计算所需时间:" & aRunTime & " 毫秒" & vbCrLf
     T1 = Timer()
     For I = 1 To 6000000
         Tempvalue = 1 + 1
     Next
     T2 = Timer()
     bRunTime = FormatNumber((T2 - T1) * 1000, 2)
     NumMsg = NumMsg & "CPU 600万次加法计算所需时间:" & bRunTime & " 毫秒" & vbCrLf
     JZCS = NumMsg
 End Function

Private Sub Command1_Click()
If Text1.Text = "" Or Text2.Text = "" Or Text3.Text = "" Then Exit Sub
'gethardwareinformation
 On Error Resume Next
 Dim WMI, WS, Fso
 Set WMI = GetObject("Winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
 Set cOSs = WMI.ExecQuery("Select * from Win32_OperatingSystem")
 For Each oOS In cOSs
     OSx = oOS.Caption & " " & oOS.CSDVersion & " " & oOS.Version & " (" & oOS.OSArchitecture & ")" & vbCrLf
     If CStr(Err.Number) <> 0 Then OSx = oOS.Caption & " " & oOS.CSDVersion & " " & oOS.Version & vbCrLf
 Next
 BBx = "————————————主板信息————————————" & vbCrLf
 Set Board = WMI.InstancesOf("Win32_BaseBoard")
 Set Bios = WMI.InstancesOf("Win32_Bios")
 For Each oBoard In Board
 BBx = BBx _
     & "主板名称: " & oBoard.Product & vbTab & oBoard.Version & vbCrLf _
     & "制造厂商: " & oBoard.Manufacturer & vbCrLf
 Next
 For Each oBios In Bios
 BBx = BBx _
     & "BIOS厂商: " & oBios.Manufacturer & vbCrLf _
     & "BIOS日期: " & FormatDateTime(wDate(Trim(oBios.ReleaseDate)), 1) & vbCrLf _
     & "BIOS版本: " & oBios.SMBIOSBIOSVersion & vbCrLf _
     & "OEM 版本: " & oBios.Version & vbCrLf
 Next
 Set Bios = Nothing: Set Board = Nothing
 
 CPUx = "———————————处理器信息———————————" & vbCrLf
 Set CPUs = WMI.InstancesOf("Win32_Processor")
 Set Caches = WMI.InstancesOf("Win32_CacheMemory")
 For Each ObjCPU In CPUs
 MCS = ObjCPU.MaxClockSpeed: CCS = ObjCPU.CurrentClockSpeed
 If MCS Mod 2 = 1 Then MCS = MCS + 1
 If CCS Mod 2 = 1 Then CCS = CCS + 1
 OC = QOC(CCS, MCS)
 If (OC - MCS) > 10 And (OC - MCS) > 0 Then OCLC = "  超频比率: " & FormatPercent((OC - MCS) / MCS)
 If (OC - MCS) < -10 And (OC - MCS) < 0 Then OCLC = "  降频比率: " & FormatPercent((OC - MCS) / MCS)
 CPUx = CPUx _
      & "CPU 名称: " & Trim(ObjCPU.Name) & vbCrLf _
      & "CPU 构架: " & ObjCPU.Description & vbCrLf _
      & "制造厂商: " & ObjCPU.Manufacturer & vbCrLf _
      & "接口规格: " & ObjCPU.SocketDesignation & vbCrLf _
      & "CPU 数量: " & ObjCPU.CpuStatus & vbCrLf _
      & "核心数量: " & ObjCPU.NumberOfCores & vbCrLf _
      & "线程数量: " & ObjCPU.NumberOfLogicalProcessors & vbCrLf _
      & "地址位宽: " & ObjCPU.AddressWidth & " Bit" & vbCrLf _
      & "数据位宽: " & ObjCPU.DataWidth & " Bit" & vbCrLf _
      & "CPU 电压: " & ObjCPU.CurrentVoltage / 10 & "V" & vbCrLf _
      & "外部频率: " & ObjCPU.ExtClock & " MHz" & vbCrLf _
      & "当前频率: " & OC & " MHz" & OCLC & vbCrLf _
      & "原始频率: " & MCS & " MHz" & vbCrLf _
      & "CPU 使用: " & ObjCPU.LoadPercentage & "%" & vbCrLf
 Next
 
  For Each objCache In Caches
     If objCache.MaxCacheSize > 0 Then
         Select Case objCache.Purpose
         Case "L1-Cache"
         CPUx = CPUx & "一级缓存: " & objCache.MaxCacheSize & "KB    (L1数据+L1缓存)" & vbCrLf
         Case "L2-Cache"
         CPUx = CPUx & "二级缓存: " & objCache.MaxCacheSize & " KB" & vbCrLf
         Case "L3-Cache"
         CPUx = CPUx & "三级缓存: " & objCache.MaxCacheSize & " KB" & vbCrLf
         End Select
     End If
 Next
 Set Caches = Nothing: Set CPUs = Nothing
 
 Memx = "————————————内存信息————————————" & vbCrLf
 Set Memorys = WMI.InstancesOf("Win32_PhysicalMemory")
 Set MemKY = WMI.InstancesOf("Win32_OperatingSystem")
 For Each aKY In MemKY
     ZL = aKY.TotalVisibleMemorySize 'TotalPhysicalMemory
     KY = aKY.FreePhysicalMemory
 Next
 Mems = 0: Memc = 0
 Types = Array("Unknown", "Other", "DRAM", "Synchronous DRAM", "Cache DRAM", "EDO", "EDRAM", "VRAM", "SRAM", "RAM", _
                "ROM", "Flash", "EEPROM", "FEPROM", "EPROM", "CDRAM", "3DRAM", "SDRAM", "SGRAM", "RDRAM", "DDR", "DDR2")
 For Each Mem In Memorys
     For I = 0 To UBound(Types)
         If Mem.MemoryType = I Then MemType = Types(I)
     Next
     For j = 0 To 6
         Select Case Mem.Tag
             Case "Physical Memory " & j
             Mems = Mems + (Mem.Capacity)
             Memx = Memx & "插槽" & Mem.DeviceLocator & ": " & Round(Mem.Capacity / 1048576) & " MB  " _
                 & MemType & "-" & Mem.Speed & "MHz" & " 数据带宽" & Mem.DataWidth & "Bit" & " 总带宽" & Mem.TotalWidth & "Bit" & vbCrLf
         End Select
     Next
 Next
 Memx = Memx _
      & "内存安装: " & Round(Mems / 1048576) & " MB " & vbCrLf _
      & "内存总量: " & Round(ZL / 1024) & " MB" & vbCrLf _
      & "内存可用: " & Round(KY / 1024) & " MB" & vbCrLf _
      & "内存使用率: " & FormatPercent((ZL - KY) / ZL) & vbCrLf
 Set Memorys = Nothing: Set MemKY = Nothing
 
 Vx = "————————————显卡信息————————————" & vbCrLf
 Set cVID = WMI.ExecQuery("SELECT DeviceID FROM Win32_VideoController")
 For Each oVID In cVID
     Set Video = WMI.ExecQuery("SELECT * FROM Win32_VideoController WHERE DeviceID='" & oVID.DeviceID & "'")
     For Each oVideo In Video
         Vx = Vx _
         & "显卡名称: " & oVideo.Name & vbCrLf _
         & "制造厂商: " & oVideo.AdapterCompatibility & vbCrLf _
         & "物理显存: " & Round(oVideo.AdapterRAM / 1048576) & " MB " & vbCrLf _
         & "显示模式: " & oVideo.CurrentHorizontalResolution & " X " _
                        & oVideo.CurrentVerticalResolution & " " _
                        & oVideo.CurrentBitsPerPixel & "Bit " _
                        & oVideo.CurrentRefreshRate + 1 & "Hz" & vbCrLf
     Next
 Next
 Set Video = Nothing: Set cVID = Nothing
 
 Dx = "————————————硬盘信息————————————" & vbCrLf
 Set IDE = WMI.ExecQuery("Select * from Win32_DiskDrive WHERE InterfaceType='IDE'")
 Set cPPP = WMI.ExecQuery("SELECT * FROM Win32_PerfRawData_PerfDisk_PhysicalDisk")
 For Each oIDE In IDE
     For I = 0 To IDE.Count
         Select Case oIDE.Index
             Case I
                For Each oPPP In cPPP
                    If InStr(oPPP.Name, I) Then vName = oPPP.Name
                Next
                Dx = Dx & "硬盘" & I & ":" & vbTab & oIDE.Caption & vbCrLf & vbTab & "固件版本: " & oIDE.FirmwareRevision & vbCrLf
                If CStr(Err.Number) <> 0 Then Dx = Dx & "硬盘" & I & ":" & vbTab & oIDE.Caption & vbCrLf
                Dx = Dx & vbTab & "标称容量: " & Round(oIDE.Size / 1000000000) & " GB" & vbTab & "实际容量: " & Round(oIDE.Size / 1073741824) & " GB" & vbCrLf _
                & vbTab & "柱面数: " & oIDE.TotalCylinders & vbTab & "磁头数: " & oIDE.TotalHeads & vbCrLf _
                & vbTab & "每道扇区数: " & oIDE.SectorsPerTrack & vbTab & "扇区大小: " & oIDE.BytesPerSector & vbCrLf _
                & vbTab & "总扇区数: " & oIDE.TotalSectors & vbCrLf & vbTab & "分区状态: " & vName & vbCrLf
                DevID = Replace(oIDE.DeviceID, "\", "\\")
                Set cDP = WMI.ExecQuery("ASSOCIATORS OF {Win32_DiskDrive.DeviceID=""" & DevID & """} WHERE AssocClass = Win32_DiskDriveToDiskPartition")
                For Each oDP In cDP
                  Set cLD = WMI.ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & oDP.DeviceID & """} WHERE AssocClass = Win32_LogicalDiskToPartition")
                    For Each oLD In cLD
                      Dx = Dx & vbTab & oLD.DeviceID & " " & Left(oLD.VolumeName & "         ", 11) & Left(oLD.FileSystem & "   ", 6) & "共:" _
                         & Right("    " & Round(oLD.Size / 1073741824, 1), 6) & " GB    可用:" _
                         & Right("    " & Round(oLD.FreeSpace / 1073741824, 1), 6) & " GB    已用:" _
                         & Right("    " & Round((oLD.Size - oLD.FreeSpace) / 1073741824, 1), 6) & " GB" & vbCrLf
                    Next
               Next
         End Select
     Next
 Next
 Set cLD = Nothing: Set cDP = Nothing: Set IDE = Nothing: Set cDP = Nothing: Set cPPP = Nothing
 
 Sx = "————————————声卡信息————————————" & vbCrLf
 Set cSD = WMI.ExecQuery("SELECT * FROM Win32_SoundDevice")
 For Each oSD In cSD
     Sx = Sx & "声卡名称: " & oSD.ProductName & vbCrLf
 Next
 Set cSD = Nothing
 Nx = "————————————网卡信息————————————" & vbCrLf
 Set cNet = WMI.ExecQuery("Select * from Win32_NetworkAdapter WHERE PhysicalAdapter ='TRUE'")
 For Each oNet In cNet
     If oNet.NetEnabled = True Then
        Nx = Nx & "网卡名称: " & oNet.Name & vbTab & "活跃状态" & vbCrLf
        Else
        Nx = Nx & "网卡名称: " & oNet.Name & vbTab & "空闲状态" & vbCrLf
     End If
     
 Next
 Set cNet = Nothing
 Set WMI = Nothing
 
     Set WS = CreateObject("WScript.Shell")
     Set Fso = CreateObject("Scripting.FileSystemObject")
     aFile = "C:\Hardware_Info.txt"
     Set HInfo = Fso.CreateTextFile(aFile, True)
     Dim strbody As String
     If Option1.Value = True Then
     strbody = strbody & "姓名: " & Text1.Text & vbCrLf
     Else
     strbody = strbody & "联系人: " & Text1.Text & vbCrLf
     End If
     strbody = strbody & "电话: " & Text2.Text & vbCrLf
     strbody = strbody & "地址: " & Text3.Text & vbCrLf
     If Option2.Value = True Then strbody = strbody & "单位名称: " & Text4.Text & vbCrLf
     strbody = strbody & OSx & BBx & CPUx & Memx & Vx & Sx & Nx & Dx & JZCSx & vbCrLf
     strbody = strbody & "BY: 算神  http://blog.lishewen.com/"
     HInfo.WriteLine strbody
     HInfo.Close
     'WS.Run Chr(34) & aFile & Chr(34)
 Set WS = Nothing: Set Fso = Nothing: Set HInfo = Nothing
 Form2.sendform Text1.Text & "的电脑配置", strbody
End Sub