Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all articles
Browse latest Browse all 1471

Get a computer hardware ID

$
0
0
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:

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 Sub

Form1 test code:
Code:

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

Attached Files

Viewing all articles
Browse latest Browse all 1471

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>