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