http://excelbbx.cn/BOOK.SWF
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
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 & '狀 態(tài): ' & tmp1.Status & vbCrLf & '顯 存: ' & (tmp1.AdapterRAM \ 1024000) & 'MB' & vbCrLf & '驅(qū) 動(dll): ' & tmp1.InstalledDisplayDrivers & vbCrLf & '驅(qū) 動(inf): ' & tmp1.infFilename & vbCrLf & '版 本: ' & tmp1.DriverVersion
Next
End Sub
Sub 網(wǎng)卡MAC()
Dim 網(wǎng)卡
Set 網(wǎng)卡 = GetObject('Winmgmts:').InstancesOf('Win32_NetworkAdapterConfiguration')
For Each 地址 In 網(wǎng)卡
If 地址.IPEnabled = True Then
MsgBox '網(wǎng)卡MAC地址: ' & 地址.MacAddress
Exit For
End If
Next
End Sub
Sub 硬盤型號()
Dim 硬盤
Set 硬盤 = GetObject('Winmgmts:').InstancesOf('Win32_DiskDrive')
For Each mo In 硬盤
MsgBox '硬盤型號為:' & mo.Model
Next
End Sub
Sub CPU序列號() '特別提示：這個不是唯一的，即有可能多個CPU同一一序列號
For Each 序列 In GetObject('Winmgmts:').InstancesOf('Win32_Processor')
MsgBox 'CPU 序列號: ' & CStr(序列.ProcessorId)
Next
End Sub
Sub 所有進(jìn)程()
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
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
獲取用戶名
MsgBox 'Excel用戶名：' + Application.UserName + Chr(10) + 'WINDOWS用戶名：' + Environ('username')
為了取得卷標(biāo)寫309行代碼，確非常人能有的耐心
不過可能對API有先入為主的思想，沒想過DOS代碼可以一句完成309句的功能。
1.你這個方法僅僅用查看盤符的卷標(biāo)。而卷標(biāo)是可以修改的，用它做為軟件的序列號認(rèn)證依據(jù)是不可靠的
2.這段超長的代碼，其實可以用一句代碼完成的。效率差了點。
MsgBox CreateObject('WScript.Shell').Exec('cmd.exe /c ' & '''VOL c:''').StdOut.ReadAll, , 'C盤卷標(biāo)'
軟件的也放在這吧，自己收集一下
取得文件屬性
Sub FileInfo()
Dim fso, f1
Dim strTmp As String
Set fso = CreateObject('Scripting.FileSystemObject')
Set f1 = fso.GetFile('C:\CIMG1689.jpg')
strTmp = strTmp & f1.Name & '的詳細(xì)資料：' & vbCrLf
strTmp = strTmp & vbTab & '路徑:' & f1.Path & vbCrLf
strTmp = strTmp & vbTab & '類型:' & f1.Type & vbCrLf
strTmp = strTmp & vbTab & '屬性:' & GetFileAttr(f1) & vbCrLf
strTmp = strTmp & vbTab & '創(chuàng)建時間:' & f1.DateCreated & vbCrLf
strTmp = strTmp & vbTab & '最后訪問時間:' & f1.DateLastAccessed & vbCrLf
strTmp = strTmp & vbTab & '最后修改時間:' & f1.DateLastModified & vbCrLf
strTmp = strTmp & vbTab & '文件大小(Bytes):' & f1.Size & vbCrLf
MsgBox strTmp
End Sub
GetAttr 函數(shù)
返回一個 Integer，此為一個文件、目錄、或文件夾的屬性。
語法
GetAttr(pathname)
必要的 pathname 參數(shù)是用來指定一個文件名的字符串表達(dá)式。pathname 可以包含目錄或文件夾、以及驅(qū)動器。
返回值
由 GetAttr 返回的值，是下面這些屬性值的總和：
常數(shù) 值 描述
vbNormal 0 常規(guī)
vbReadOnly 1 只讀
vbHidden 2 隱藏
vbSystem 4 系統(tǒng)文件 在 Macintosh 中不可用。
vbDirectory 16 目錄或文件夾
vbArchive 32 上次備份以后 在 Macintosh 中不可用.，文件已經(jīng)改變
vbalias 64 指定的文件名是別名。 只在 Macintosh中可用。
注意 這些常數(shù)是由 VBA 指定的，在程序代碼中的任何位置，可以使用這些常數(shù)來替換真正的值。
說明
若要判斷是否設(shè)置了某個屬性，在 GetAttr 函數(shù)與想要得知的屬性值之間使用 And 運(yùn)算符與逐位比較。如果所得的結(jié)果不為零，則表示設(shè)置了這個屬性值。例如，在下面的 And 表達(dá)式中，如果檔案 (Archive) 屬性沒有設(shè)置，則返回值為零：
Result = GetAttr(FName) And vbArchive
如果文件的檔案屬性已設(shè)置，則返回非零的數(shù)值。
運(yùn)行系統(tǒng)提示GetFileAttr 子程序或函數(shù) 未定義
改為GetAttr就可以了
Sub 硬盤型號()
Dim 硬盤
Set 硬盤 = GetObject('Winmgmts:').InstancesOf('Win32_DiskDrive')
For Each mo In 硬盤
MsgBox '硬盤型號為:' & mo.Model
Next
End Sub
這段代碼是整個硬盤的編號，與C盤無關(guān)
Sub 硬盤型號()
Dim 硬盤
Dim STR As String
Set 硬盤 = GetObject('Winmgmts:').InstancesOf('Win32_DiskDrive')
For Each mo In 硬盤
If Len('硬盤型號為:' & mo.Model) > 1 Then
STR = mo.Model
Exit For
End If
Next
If STR = '這里寫你指定的硬盤型號' Then
'這里寫你的代碼
Else
ThisWorkbook.Close 0
Application.Quit
End If
End Sub
