This code is for identifying a computer. It returns a number corresponding to that Motherboard/Processor/NetworkAdapter
And it also returns a number for each disk.
The functions are: GetComputerIDNumber, GetDiskCount and GetDiskIDNumber(i)
mComputerID bas module code:
Form1 test code:
And it also returns a number for each disk.
The functions are: GetComputerIDNumber, GetDiskCount and GetDiskIDNumber(i)
mComputerID bas module code:
Code:
Option Explicit
Private Declare Function RoGetActivationFactory Lib "combase" (ByVal activatableClassId As Long, rIID As Any, lpFactory As Any) As Long
Private Declare Function WindowsCreateString Lib "combase" (ByVal sourceString As Long, ByVal length As Long, hString As Long) As Long
Private Declare Function WindowsDeleteString Lib "combase" (ByVal hString As Long) As Long
Private Declare Function WindowsGetStringRawBuffer Lib "combase" (ByVal hString As Long, length As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpString As Long, rIID As Any) As Long
Private Declare Function SysReAllocString Lib "oleaut32" Alias "#3" (ByVal pBSTR As Long, ByVal pStr As Long) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgvt As Any, prgpvarg As Any, pvargResult As Variant) As Long
Private Declare Function HashDataAny Lib "shlwapi" Alias "HashData" (ByVal pbData As Long, ByVal cbData As Long, ByRef pbHash As Any, ByVal cbHash As Long) As Long
Private IID_ISystemIdentificationStatics(0 To 3) As Long
Private IID_ICryptographicBufferStatics(0 To 3) As Long
Private Declare Function GetSystemFirmwareTable Lib "kernel32" (ByVal FirmwareTableProviderSignature As Long, ByVal FirmwareTableID As Long, FirmwareTableBuffer As Any, ByVal BufferSize As Long) As Long
Private Declare Function StringFromGUID2 Lib "ole32" (uGUID As Any, ByVal lpSz As Long, ByVal cchMax As Long) As Long
Private Const NCBASTAT As Long = &H33
Private Const NCBRESET As Long = &H32
Private Const NCBENUM As Long = &H37
Private Const NRC_GOODRET As Long = &H0
Private Const MAX_LANA As Long = 254
Private Const NCBNAMSZ As Long = 16
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Const HEAP_GENERATE_EXCEPTIONS As Long = &H4
Private Type LANA_ENUM
length As Byte
adapter_numbers(0 To MAX_LANA) As Byte 'lanas in range 0 to MAX_LANA inclusive
End Type
Private Type NET_CONTROL_BLOCK 'NCB
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve(0 To 9) As Byte 'if Win64, make (0 to 17)
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(0 To 5) As Byte '6 elements
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(0 To 30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NET_CONTROL_BLOCK) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private mDiskInfoRetrieved As Boolean
Private mDiskCount As Long
Private mDiskIDString() As String
Private mDiskIDNumber() As String
'from https://www.vbforums.com/showthread.php?905201-Identify-computer&p=5648565&viewfull=1#post5648565
Private Function GetSystemIdentificationInfo2(Optional lSource As Long) As String
Const SystemIdentification As String = "Windows.System.Profile.SystemIdentification"
Const SystemIdentificationInfo As String = "Windows.System.Profile.SystemIdentificationInfo"
Const CryptographicBuffer As String = "Windows.Security.Cryptography.CryptographicBuffer"
Const IDX_GetSystemIdForPublisher As Long = 6
Const IDX_GetId As Long = 6
Const IDX_GetSource As Long = 7
Const IDX_EncodeToHexString As Long = 12
Dim pSysIdent As stdole.IUnknown
Dim pInfo As stdole.IUnknown
Dim pId As stdole.IUnknown
Dim pCryptoBuf As stdole.IUnknown
Dim hString As Long
Dim hResult As Long
Dim sApiSource As String
On Error GoTo EH
If IID_ISystemIdentificationStatics(0) = 0 Then
Call IIDFromString(StrPtr("{5581F42A-D3DF-4D93-A37D-C41A616C6D01}"), IID_ISystemIdentificationStatics(0))
Call IIDFromString(StrPtr("{320B7E22-3CB0-4CDF-8663-1D28910065EB}"), IID_ICryptographicBufferStatics(0))
End If
'--- auto id = Windows::System::Profile::SystemIdentification::GetSystemIdForPublisher()->Id
Set pSysIdent = CreateFactory(SystemIdentification, IID_ISystemIdentificationStatics(0))
If pSysIdent Is Nothing Then
GoTo QH
End If
hResult = DispCallByVtbl(pSysIdent, IDX_GetSystemIdForPublisher, VarPtr(pInfo))
If hResult < 0 Then
sApiSource = SystemIdentification & ".GetSystemIdForPublisher"
GoTo QH
End If
hResult = DispCallByVtbl(pInfo, IDX_GetId, VarPtr(pId))
If hResult < 0 Then
sApiSource = SystemIdentificationInfo & ".GetId"
GoTo QH
End If
hResult = DispCallByVtbl(pInfo, IDX_GetSource, VarPtr(lSource))
If hResult < 0 Then
sApiSource = SystemIdentificationInfo & ".GetSource"
GoTo QH
End If
'--- auto asHex = Windows::Security::Cryptography::CryptographicBuffer::EncodeToHexString(id)
Set pCryptoBuf = CreateFactory(CryptographicBuffer, IID_ICryptographicBufferStatics(0))
If pCryptoBuf Is Nothing Then
GoTo QH
End If
hResult = DispCallByVtbl(pCryptoBuf, IDX_EncodeToHexString, ObjPtr(pId), VarPtr(hString))
If hResult < 0 Then
sApiSource = CryptographicBuffer & ".EncodeToHexString"
GoTo QH
End If
Call SysReAllocString(VarPtr(GetSystemIdentificationInfo2), WindowsGetStringRawBuffer(hString, 0))
QH:
If hString <> 0 Then
hString = WindowsDeleteString(hString)
End If
If LenB(sApiSource) <> 0 Then
Err.Raise hResult, sApiSource
End If
Exit Function
EH:
hResult = Err.Number
sApiSource = Err.Source
Resume QH
End Function
Private Function CreateFactory(sClassID As String, rIID As Long) As stdole.IUnknown
Dim hString As Long
Dim hResult As Long
Dim sApiSource As String
On Error GoTo EH
hResult = WindowsCreateString(StrPtr(sClassID), Len(sClassID), hString)
If hResult < 0 Then
sApiSource = "WindowsCreateString"
GoTo QH
End If
hResult = RoGetActivationFactory(hString, rIID, CreateFactory)
If hResult < 0 Then
sApiSource = "RoGetActivationFactory"
GoTo QH
End If
QH:
If hString <> 0 Then
hString = WindowsDeleteString(hString)
End If
If LenB(sApiSource) <> 0 Then
Err.Raise hResult, sApiSource
End If
Exit Function
EH:
hResult = Err.Number
sApiSource = Err.Source
Resume QH
End Function
Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
Const CC_STDCALL As Long = 4
Dim lIdx As Long
Dim vParam() As Variant
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As Long
Dim hResult As Long
vParam = A
For lIdx = 0 To UBound(vParam)
vType(lIdx) = VarType(vParam(lIdx))
vPtr(lIdx) = VarPtr(vParam(lIdx))
Next
hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function
' from https://www.vbforums.com/showthread.php?905201-Identify-computer&p=5648193&viewfull=1#post5648193
Private Function GetMachineUUID(Optional Error As String) As String
Const LNG_RSMB As Long = &H52534D42 '-- "RSMB"
Dim lSize As Long
Dim baBuffer() As Byte
Dim lIdx As Long
Dim lOffset As Long
lSize = GetSystemFirmwareTable(LNG_RSMB, 0, ByVal 0, 0)
ReDim baBuffer(0 To lSize) As Byte
If GetSystemFirmwareTable(LNG_RSMB, 0, baBuffer(0), lSize) <> lSize Then
Error = "Failed GetSystemFirmwareTable"
GoTo QH
End If
lIdx = 8
Do While lIdx < lSize - 16
If baBuffer(lIdx) = 1 Then
lOffset = lIdx + 8
Exit Do
End If
lIdx = lIdx + baBuffer(lIdx + 1)
Do While baBuffer(lIdx) <> 0 Or baBuffer(lIdx + 1) <> 0
lIdx = lIdx + 1
Loop
lIdx = lIdx + 2
Loop
If lOffset = 0 Then
Error = "Cannot find UUID in raw data"
GoTo QH
End If
GetMachineUUID = Space$(38)
Call StringFromGUID2(baBuffer(lOffset), StrPtr(GetMachineUUID), Len(GetMachineUUID) + 1)
QH:
End Function
' from http://vbnet.mvps.org/index.html?code/network/netbiosenumlana.htm
Private Function GetNBMacAddresses(sMACAddresses() As String, sDelimiter As String) As Long
Dim cnt As Long
Dim pASTAT As Long
Dim buff As String
Dim lana As LANA_ENUM 'enum values
Dim ncb As NET_CONTROL_BLOCK
Dim ast As ASTAT
With ncb
.ncb_command = NCBENUM
.ncb_length = LenB(lana)
.ncb_buffer = VarPtr(lana)
End With
Call Netbios(ncb)
If ncb.ncb_retcode = NRC_GOODRET Then
ReDim sMACAddresses(0 To lana.length - 1)
For cnt = 0 To lana.length - 1
With ncb
.ncb_command = NCBRESET
.ncb_lana_num = lana.adapter_numbers(cnt)
End With
Call Netbios(ncb)
If ncb.ncb_retcode = NRC_GOODRET Then
With ncb
.ncb_command = NCBASTAT
.ncb_lana_num = lana.adapter_numbers(cnt)
.ncb_length = Len(ast)
.ncb_callname = Space$(16)
Mid$(.ncb_callname, 1, 1) = "*"
End With
pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, ncb.ncb_length)
If pASTAT <> 0 Then
ncb.ncb_buffer = pASTAT
Call Netbios(ncb)
If ncb.ncb_retcode = NRC_GOODRET Then
CopyMemory ast, ncb.ncb_buffer, Len(ast)
sMACAddresses(cnt) = MakeMacAddress(ast.adapt.adapter_address(), sDelimiter)
HeapFree GetProcessHeap(), 0, pASTAT
End If
End If
End If
Next
GetNBMacAddresses = lana.length
End If
End Function
Private Function MakeMacAddress(b() As Byte, sDelim As String) As String
Dim cnt As Long
Dim buff As String
On Local Error GoTo MakeMac_error
If UBound(b) = 5 Then
For cnt = 0 To 4
buff = buff & Right$("00" & Hex(b(cnt)), 2) & sDelim
Next
buff = buff & Right$("00" & Hex(b(5)), 2)
End If
MakeMacAddress = buff
MakeMac_exit:
Exit Function
MakeMac_error:
MakeMacAddress = "(error building MAC address)"
Resume MakeMac_exit
End Function
Private Function BitsNeededForDecimals(ByVal NumDecimals As Long) As Long
BitsNeededForDecimals = Int(Log(10 ^ NumDecimals) / Log(2)) + 1
End Function
Public Function GetComputerIDString() As String
Dim iSource As Long
Dim iStr As String
Dim o As Object
iStr = GetSystemIdentificationInfo2(iSource)
If (iSource > 0) And (iSource < 3) Then
GetComputerIDString = iStr & "|"
End If
On Error Resume Next
Set o = GetObject("winmgmts:")
' from https://www.vbforums.com/showthread.php?905201-Identify-computer&p=5649565&viewfull=1#post5649565
GetComputerIDString = GetComputerIDString & o.ExecQuery("SELECT ProcessorID FROM Win32_Processor WHERE ProcessorID is NOT NULL").ItemIndex(0).ProcessorID & "|"
GetComputerIDString = GetComputerIDString & o.ExecQuery("SELECT Manufacturer FROM Win32_BaseBoard WHERE Manufacturer is NOT NULL").ItemIndex(0).Manufacturer & "|"
GetComputerIDString = GetComputerIDString & o.ExecQuery("SELECT Product FROM Win32_BaseBoard WHERE Product is NOT NULL").ItemIndex(0).Product & "|"
GetComputerIDString = GetComputerIDString & o.ExecQuery("SELECT Version FROM Win32_BIOS WHERE Version is NOT NULL").ItemIndex(0).Version
Dim iError As String
Dim iUUID As String
iUUID = GetMachineUUID(iError)
If (iError = "") And (iUUID <> "") Then
GetComputerIDString = GetComputerIDString & "|" & iUUID
End If
Dim iMacCount As Long
Dim iMACAddresses() As String
iMacCount = GetNBMacAddresses(iMACAddresses(), ":")
If iMacCount > 0 Then
GetComputerIDString = GetComputerIDString & "|" & iMACAddresses(0)
End If
End Function
Public Function GetComputerIDNumber(Optional ByVal nDigits As Long = 10) As String
Dim b As Long
Dim iComputerString As String
Dim iBytes() As Byte
Dim v As Variant
Dim c As Long
If nDigits < 1 Then nDigits = 1
If nDigits > 30 Then Err.Raise 5: nDigits = 30
b = BitsNeededForDecimals(nDigits) / 8
If b = 0 Then b = 1
iComputerString = GetComputerIDString
ReDim iBytes(b - 1)
HashDataAny StrPtr(iComputerString), 2 * Len(iComputerString), iBytes(0), b
v = CDec(0)
For c = 0 To UBound(iBytes)
v = v + iBytes(c) * 256 ^ c
Next c
GetComputerIDNumber = Right$("00" & Trim$(Str$(v)), nDigits)
End Function
Public Function GetDiskCount() As Long
If Not mDiskInfoRetrieved Then RetrieveDiskInfo
GetDiskCount = mDiskCount
End Function
Public Function GetDiskIDString(Optional nDiskIndex As Long = 0) As String
If Not mDiskInfoRetrieved Then RetrieveDiskInfo
GetDiskIDString = mDiskIDString(nDiskIndex)
End Function
Public Function GetDiskIDNumber(Optional nDiskIndex As Long = 0, Optional ByVal nDigits As Long = 10) As String
Dim iStr As String
Dim b As Long
Dim iDiskString As String
Dim iBytes() As Byte
Dim v As Variant
Dim c As Long
If nDigits < 1 Then nDigits = 1
If nDigits > 30 Then Err.Raise 5: nDigits = 30
iStr = GetDiskIDString(nDiskIndex)
If iStr <> "" Then
b = BitsNeededForDecimals(nDigits) / 8
If b = 0 Then b = 1
iDiskString = GetDiskIDString(nDiskIndex)
ReDim iBytes(b - 1)
HashDataAny StrPtr(iDiskString), 2 * Len(iDiskString), iBytes(0), b
v = CDec(0)
For c = 0 To UBound(iBytes)
v = v + iBytes(c) * 256 ^ c
Next c
GetDiskIDNumber = Right$("00" & Trim$(Str$(v)), nDigits)
End If
End Function
Private Sub RetrieveDiskInfo()
Dim iDiskInfoObj As Object
Dim o As Object
If mDiskInfoRetrieved Then Exit Sub
Set iDiskInfoObj = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive")
On Error Resume Next
mDiskCount = iDiskInfoObj.Count
ReDim mDiskIDString(mDiskCount - 1)
ReDim mDiskIDNumber(mDiskCount - 1)
For Each o In iDiskInfoObj
mDiskIDString(o.Index) = o.Model & "|" & o.SerialNumber & "|" & o.Size
Next o
mDiskInfoRetrieved = True
End SubCode:
Option Explicit
Private Sub Form_Load()
Dim n As String
Dim c As Long
MsgBox "Computer ID String: " & vbCrLf & vbCrLf & GetComputerIDString
n = GetComputerIDNumber
n = Left$(n, 5) & "-" & Mid$(n, 6)
MsgBox "Computer ID number:" & vbCrLf & vbCrLf & n
For c = 0 To GetDiskCount - 1
MsgBox "Disk " & c & " ID String: " & vbCrLf & vbCrLf & GetDiskIDString(c)
n = GetDiskIDNumber(c)
n = Left$(n, 5) & "-" & Mid$(n, 6)
MsgBox "Disk " & c & " ID number: " & vbCrLf & vbCrLf & n
Next
End Sub