Unique Identification number

Here is some code that will get the User Name and the Computer Name.  Computer name is fairly safe but could be changed by the user at some point.  Just a warning.

Set WN = CreateObject("Wscript.Network")
MsgBox "User Name: " & WN.UserName & vbCr & "Computer Name: " & WN.ComputerName

Thanks, but I need to protect the program by using some hardware ID (hardware type and serial number). Do you have some idea?

Hi one popular method is to use Harddrive serial no:

Here is how:

http://www.zarr.net/vb/download/codedetail.asp?code=176

I know this option but I´m afraid that the harddrive serial number changes when there is change of the drive´s partitions (I have a hard drive devided into three partitions and they all have different serials!). I need a serial of the fhysical drive not of the partitions (by the way how is the harddrive serial set??? Is it count by some algorithm by Windows??)

Nice code! , the code in the link didn't work

 but above code works.

Try using this code:

http://www.pscode.com/vb/scripts/ShowCode.asp?txtCodeId=49073&lngWId=1

-Burbble

Hi
First of all, VolumeSerial != DriveSerial
If you have, say, 3 partitions on your drive, you'll get 3 serials, which changing every time you format drive or even manualy with drive editor. Check out some of my samples:
http://www.freevbcode.com/ShowCode.Asp?ID=3292 'Get BIOS info
http://www.freevbcode.com/ShowCode.Asp?ID=3380 'Get HDD serial (REAL vendor serial)
' Note - above HDD serial sample support IDE drives only, but I already have code which support SCSI drives.

'CPU serial (PIII and above, AMD Athlon)

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As String, ByRef hWnd As Long, ByRef Msg As Long, ByRef wParam As Long, ByRef lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Dim eax As Long
Dim ebx As Long
Dim ecx As Long
Dim edx As Long
Private m_CPUAsm As String

Public Function CPUVendor() As String
    eax = 0
    CallWindowProc CPUAsm, eax, ebx, ecx, edx
    CPUVendor = GetCPUVendorName(ebx, ecx, edx)
End Property

Public Function CPUSerial() As String
    eax = 0
    CallWindowProc CPUAsm, eax, ebx, ecx, edx
    If eax = 1 Then
       CallWindowProc CPUAsm, eax, ebx, ecx, edx
       CPUSerial = GetCPUSerialNo(eax, edx)
    End If
End Property

Private Function GetCPUVendorName(ebx As Long, ecx As Long, edx As Long) As String
  Dim abVendor(11) As Byte
  CopyMemory abVendor(0), ebx, 4
  CopyMemory abVendor(4), edx, 4
  CopyMemory abVendor(8), ecx, 4
  GetCPUVendorName = StrConv(abVendor, vbUnicode)
End Function

Private Function GetCPUSerialNo(eax As Long, edx As Long) As String
   GetCPUSerialNo = Right("00000000" & Hex(edx), 8) & "-" & Right("00000000" & Hex(eax), 8)
End Function

Private Function CPUAsm() As String
   If m_CPUAsm = "" Then
      Dim Asm As String
      Asm = Asm & Chr(&H56)                            '56        push   esi
      Asm = Asm & Chr(&H55)                            '55        push   ebp
      Asm = Asm & Chr(&H8B) & Chr(&HEC)                '8B EC     mov  ebp,esp
      Asm = Asm & Chr(&H8B) & Chr(&H75) & Chr(&HC)     '8B 75 0C  mov  esi,dword ptr [ebp+0Ch]
      Asm = Asm & Chr(&H8B) & Chr(&H6)                 '8B 06     mov  eax,dword ptr [esi]
      Asm = Asm & Chr(&HF) & Chr(&HA2)                 '0F A2     cpuid
      Asm = Asm & Chr(&H8B) & Chr(&H75) & Chr(&HC)     '8B 75 0C  mov  esi,dword ptr [ebp+0Ch]
      Asm = Asm & Chr(&H89) & Chr(&H6)                 '89 06     mov  dword ptr [esi],eax
      Asm = Asm & Chr(&H8B) & Chr(&H75) & Chr(&H10)    '8B 75 10  mov  esi,dword ptr [ebp+10h]
      Asm = Asm & Chr(&H89) & Chr(&H1E)                '89 1E     mov  dword ptr [esi],ebx
      Asm = Asm & Chr(&H8B) & Chr(&H75) & Chr(&H14)    '8B 75 14  mov  esi,dword ptr [ebp+14h]
      Asm = Asm & Chr(&H89) & Chr(&HE)                 '89 0E     mov  dword ptr [esi],ecx
      Asm = Asm & Chr(&H8B) & Chr(&H75) & Chr(&H18)    '8B 75 18  mov  esi,dword ptr [ebp+18h]
      Asm = Asm & Chr(&H89) & Chr(&H16)                '89 16     mov  dword ptr [esi],edx
      Asm = Asm & Chr(&H5D)                            '5D        pop  ebp
      Asm = Asm & Chr(&H5E)                            '5E        pop  esi
      Asm = Asm & Chr(&HC2) & Chr(&H10) & Chr(&H0)     'C2 10 00  ret  10h
      m_CPUAsm = Asm
   End If
   CPUAsm = m_CPUAsm
End Function

PS. Also, do a search for MAC address - there are tons of samples over the net.
If you're using WinXP, I can supply code for WMI

Hi Ark,

Nice codes:

1:the HD code is very nice worked perfectly!
2: the bios code didn't work on my computer

3: cpu code didn't work, but is very interesting: ( i have PIII 1000)
 i'm suspicious to this section:

Public Function CPUSerial() As String
    eax = 0
    CallWindowProc CPUAsm, eax, ebx, ecx, edx
    If eax = 1 Then  '<=================== on my computer eax is 2 so i guess this code should run
       CallWindowProc CPUAsm, eax, ebx, ecx, edx
       CPUSerial = GetCPUSerialNo(eax, edx)
    End If
End Function

Oh.. thanks for pointing me on this prb. Of course, it should be

Public Function CPUSerial() As String
    eax = 0
    CallWindowProc CPUAsm, eax, ebx, ecx, edx
'After executing asm code with eax = 0, eax return max available levels of information
'First level return CPUId in eax and edx registers
'Documents says that ecx register also should contain info, but it was always 0 at my (Athlon +) machine.
    If eax > 0 Then  '<=================== Changed!
       CallWindowProc CPUAsm, eax, ebx, ecx, edx
       CPUSerial = GetCPUSerialNo(eax, edx)
    End If
End Function

'BIOS sample should work on all platforms, though it doesn't retrive BIOS serial under NT/2k/XP. For NT platforms you can use following trick:

'================bas module code==============
Const BATCH_FILE = "bios.bat"
Const TEXT_FILE = "bios.txt"

Public Function ReadBiosData(ByVal dwAddress As Long, ByVal nBytes As Long) As String
  Dim sAddress As String, sSegment As String, sOffset As String
  Dim sString As String, sBytes As String, sInfo As String
  Dim nPos As Integer
  sAddress = Hex(dwAddress)
  On Error Resume Next
  sSegment = Left(sAddress, Len(sAddress) - 4)
  sSegment = Left(sSegment & "0000", 4)
  sOffset = Right(sAddress, 4)
  sAddress = sSegment & ":" & sOffset
'create bat file
  If Dir(BATCH_FILE) <> "" Then Kill BATCH_FILE
  If Dir(TEXT_FILE) <> "" Then Kill TEXT_FILE
  Open BATCH_FILE For Output As #1
       Print #1, "echo d " & sAddress & " l " & Hex(nBytes) & " >bios$.$"
       Print #1, "echo q>>bios$.$"
       Print #1, "debug.exe<bios$.$>" & TEXT_FILE
       Print #1, "del bios$.$"
  Close #1
  Shell BATCH_FILE
  While Dir(TEXT_FILE) = ""
     DoEvents
  Wend
  While FileLen(TEXT_FILE) = 0
     DoEvents
  Wend
  Open TEXT_FILE For Input As #1
     Line Input #1, sString
     Do While Not EOF(1)
      Line Input #1, sString
      sBytes = Mid(sString, 11, 48)
      nPos = InStr(1, sBytes, "00")
      If nPos Then
         sInfo = sInfo & Left(Trim(Mid(sString, 59)), (nPos - 1) / 3)
         Exit Do
      End If
      sInfo = sInfo & Trim(Mid(sString, 59))
     Loop
  Close #1
  ReadBiosData = sInfo
  Kill BATCH_FILE
  Kill TEXT_FILE
End Function

'Using
Private Sub Command1_Click()
  MsgBox "BIOS serial = " & ReadBiosData(&HFEC71, 50)
End Sub

Thanks guys, in the close future I´m going to try your suggestions - If I will be able, I´m absolut beginner... :-(
Do you have some ideas how to solve the same problem in MS Excel - VBA : I mean I want the *.xls file could be opened only on a uniqely identified computer (HDD, Motherboard, CPU) ???
Thanks a lot. Miua

thanks, sorry for delaying...
I haven´t tried it yet, but I hope your suggestions are ok