Unique Identification number

Hi, I need a program code that enables doing some action only if the program is launched from a certain PC. I´m thinking about checking some unique hardware identification (e.g. motherboard or bios id, cpu id or hdd id - product name and serial number) which would be written in the code.
All windows versions should be covered..

Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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
miuaAuthor Commented:
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:

Price Your IT Services for Profit

Managed service contracts are great - when they're making you money. Yes, you’re getting paid monthly, but is it actually profitable? Learn to calculate your hourly overhead burden so you can master your IT services pricing strategy.

miuaAuthor Commented:
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??)
i agree with unknown_routine the ahrd drive serai is your best solution maybe you could take that number or get all drives attahced to the pc and sum up the serail number to create a unique number

the hd serial is set when a drive is formatted.

Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

'returns serial  as hex change the funtion to return a long and remove the hex funtion if you want a number returned
Public Function GetDriveSerial(ByVal sdrive As String) As String
    Dim sBuffer As String
    Dim sSysName As String
    Dim lResult As Long
    Dim lSysFlags As Long
    Dim lComponentLength As Long
    Dim m_lSerial As Long
    sBuffer = String$(256, 0)
    sSysName = String$(256, 0)
    lResult = GetVolumeInformation(sdrive, sBuffer, 255, m_lSerial, lComponentLength, lSysFlags, sSysName, 255)
    GetDriveSerial = Hex(m_lSerial)
End Function
Nice code! , the code in the link didn't work

 but above code works.
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
  While Dir(TEXT_FILE) = ""
  While FileLen(TEXT_FILE) = 0
  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))
  Close #1
  ReadBiosData = sInfo
End Function

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

Oops... sorry again

    If eax > 0 Then  '<=================== Changed!
       eax = 1          '<=================== Added!
       CallWindowProc CPUAsm, eax, ebx, ecx, edx
       CPUSerial = GetCPUSerialNo(eax, edx)
    End If
End Function

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
miuaAuthor Commented:
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
miuaAuthor Commented:
thanks, sorry for delaying...
I haven´t tried it yet, but I hope your suggestions are ok
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.