提取硬件信息

楼主罗刚君	Sub 主板序列号() Dim objs As Object, Obj As Object, WMI As Object, 主板序列号 Set WMI = GetObject("WinMgmts:") Set objs = WMI.InstancesOf("Win32_BaseBoard") For Each Obj In objs MsgBox "您的主板序列号是：" + Obj.SerialNumber Next End Sub 可能某些操作系统无法获取成功
2楼罗刚君	Sub 显卡信息() On Error Resume Next Dim tmp1, tmp2 Set tmp2 = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_VideoController") For Each tmp1 In tmp2 MsgBox "型号: " & tmp1.VideoProcessor & vbCrLf & "厂商: " & tmp1.AdapterCompatibility & vbCrLf & "名称: " & tmp1.Name & vbCrLf & "状态: " & tmp1.Status & vbCrLf & "显存: " & (tmp1.AdapterRAM \ 1024000) & "MB" & vbCrLf & "驱动(dll): " & tmp1.InstalledDisplayDrivers & vbCrLf & "驱动(inf): " & tmp1.infFilename & vbCrLf & "版本: " & tmp1.DriverVersion Next End Sub
3楼罗刚君	Sub 网卡MAC() Dim 网卡 Set 网卡 = GetObject("Winmgmts:").InstancesOf("Win32_NetworkAdapterConfiguration") For Each 地址 In 网卡 If 地址.IPEnabled = True Then MsgBox "网卡MAC地址: " & 地址.MacAddress Exit For End If Next End Sub
4楼罗刚君	Sub 硬盘型号() Dim 硬盘 Set 硬盘 = GetObject("Winmgmts:").InstancesOf("Win32_DiskDrive") For Each mo In 硬盘 MsgBox "硬盘型号为:" & mo.Model Next End Sub
5楼罗刚君	Sub 硬盘型号() Dim 硬盘 Set 硬盘 = GetObject("Winmgmts:").InstancesOf("Win32_DiskDrive") For Each mo In 硬盘 MsgBox "硬盘型号为:" & mo.Model Next End Sub
6楼罗刚君	Sub CPU序列号() '特别提示：这个不是唯一的，即有可能多个CPU同一一序列号 For Each 序列 In GetObject("Winmgmts:").InstancesOf("Win32_Processor") MsgBox "CPU 序列号: " & CStr(序列.ProcessorId) Next End Sub
7楼罗刚君	Sub 所有进程() Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process") For Each obj In objs tmp = tmp & WorksheetFunction.Text(a + 1, "[DBNum2][$-804]0: ") + vbTab + obj.Description + Chr(13) a = a + 1 Next MsgBox tmp, 65, "提示你哦" End Sub
8楼罗刚君	Sub 所有进程() Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process") For Each obj In objs tmp = tmp & WorksheetFunction.Text(a + 1, "[DBNum2][$-804]0: ") + vbTab + obj.Description + Chr(13) a = a + 1 Next MsgBox tmp, 65, "提示你哦" End Sub
9楼罗刚君	Sub IP地址() ComputerName = "localhost" Set OpSysSet = GetObject("winmgmts:{impersonationLevel=impersonate}//" & ComputerName).ExecQuery("SELECT index, IPAddress FROM Win32_NetworkAdapterConfiguration") For Each OpSys In OpSysSet If TypeName(OpSys.IPAddress) <> "Null" Then For Each IP In OpSys.IPAddress MsgBox IP, 64, "IP地址" Next End If Next End Sub
10楼罗刚君	MsgBox "Excel用户名：" + Application.UserName + Chr(10) + "WINDOWS用户名：" + Environ("username")
11楼罗刚君	Sub 进程详情() Dim aa(), counts As Byte, i As Integer, xProcesses As Object Set xProcesses = GetObject("WinMgmts:").InstancesOf("Win32_Process") counts = xProcesses.Count + 1 i = 2 ReDim Preserve aa(1 To counts, 1 To 5) aa(1, 1) = "进程": aa(1, 2) = "用户": aa(1, 3) = "进程ID": aa(1, 4) = "内存": aa(1, 5) = "路径" For Each xProcess In xProcesses With xProcess If .GetOwner(user, Domain) = 0 Then aa(i, 1) = .Caption: aa(i, 2) = user: aa(i, 3) = .ProcessID: aa(i, 4) = .WorkingSetSize / 1024: aa(i, 5) = .ExecutablePath Else aa(i, 1) = .Caption: aa(i, 2) = "": aa(i, 3) = .ProcessID: aa(i, 4) = .WorkingSetSize / 1024: aa(i, 5) = .ExecutablePath End If End With i = i + 1 Next Range("a1:E" & counts) = aa Range("a:e").EntireColumn.AutoFit End Sub
12楼罗刚君	Sub 获取当前正运行的程序窗口名() Dim WD, task, n As Long Set WD = CreateObject("WORD.Application") For Each task In WD.Tasks If task.Visible = True Then n = n + 1 Cells(n, 1) = task.Name End If Next Set WD = Nothing End Sub
13楼罗刚君	Sub GetIP() Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2") Set colNetAdapters = objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration") For Each objNetAdapter In colNetAdapters If TypeName(objNetAdapter.IPAddress) <> "Null" Then MsgBox "网关........:" & objNetAdapter.DefaultIPGateway(0) & Chr(13) _ & "IP..........:" & objNetAdapter.IPAddress(0) & Chr(13) _ & "掩码........:" & objNetAdapter.IPSubnet(0) Exit Sub End If Next End Sub
14楼罗刚君	获取所有用户名称 Sub Click() For Each obj In GetObject("winmgmts:").ExecQuery("Select name from Win32_UserAccount") s = s & obj.Name & vbCrLf Next MsgBox s End Sub
15楼罗刚君	Sub 获取CDE盘的文件目录() CreateObject("WScript.Shell").Popup CreateObject("WScript.Shell").exec("cmd.exe /c dir c:\ d:\ e:\ /ad").StdOut.ReadAll, , "显示目录" End Sub
16楼 kszcs	呵呵,全呀,收藏学习
17楼 kevinchengcw	收藏,崇拜
18楼 ngs139	无比强大，无比崇拜
19楼 wenshui2006	学习啊,,,啊,,,,学习,, ,,,,
20楼 398829134	老师这个太强大了，需要收藏
21楼 398829134	咦，没有内存信息呢，我来补上： Sub 获取内存信息() Dim objWMI As Object, aObjs As Object, aObj As Object, sMsg As String Set objWMI = GetObject("winmgmts:\\") Set aObjs = objWMI.instancesof("win32_physicalmemory") sMsg = "内存容量：" & vbCrLf For Each aObj In aObjs sMsg = sMsg & aObj.Tag & Space(10) & aObj.capacity & vbCrLf Next Set aObjs = objWMI.instancesof("win32_computersystem") For Each aObj In aObjs sMsg = sMsg & "内存总容量：" & Round((aObj.totalphysicalmemory / 1024 ^ 2), 2) & "M" & vbCrLf Next MsgBox sMsg, vbOKOnly + vbInformation End Sub 另外，楼主上面的Word没有退出
22楼天空真蓝/qt