extract PC serial number using VBA

[jag108]

I am trying to do an audit on PC's currently in a particular building, I need to be able to extract the serial numer and enter it into a spreadhsheet.
How this needs to be achieved is by getting each user to open the spreadhsheet, which will run a macro to extract the data and put in to the relitive cell. The spreadsheet will only run once for any particular user, so there will be no duplication of data.

 

[Nimrod]

Where is this serial number located ?

 

[Tom Urtis]

Two suggestions:

(1)
If you really want the computers' serial numbers in your building, then walk through the building to each computer, and write down the numbers as they appear on their label.

(2)
That number won't mean anything, because hardware can be easily swapped, so whatever the serial number was when it left the factory can be misrepresented by altered specifications (swapped hard drive, added ram, etc). Besides, that label can be scratched off or replaced with a fake label. What you would be better off identifying is one or more hardware components to give you more of a truly unique identification of the PC.

Paste the following code in a standard module just as you see it here, and run the macro named "CompSpex". It will give you the computer's hard drive serial number and processor serial number, which is a combination that won't likely exist anywhere else on planet earth.



Option Explicit

Public ProcNum As String

Sub ProcessorNumber()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
Dim WMI As Object, WQL As String, Proc As Object, Procs As Object, i As Integer
Sheets.Add
i = 1
Set WMI = GetObject("winmgmts:")
WQL = "select * from win32_processor"
Set Procs = WMI.ExecQuery(WQL)
For Each Proc In Procs
Cells(i, 1).Value = Proc.getObjectText_
i = i + 1
Next Proc
Set WMI = Nothing
Set Procs = Nothing
With Range("B1")
.Formula = "=CLEAN(MID(RC1,SEARCH(""{"",RC1)+1,SEARCH(""}"",RC1)-SEARCH(""{"",RC1)-1))"
.Value = .Value
End With
Range("B1").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:=";", FieldInfo:=Array( _
Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), _
Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), _
Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), Array(30, 1), _
Array(31, 1), Array(32, 1), Array(33, 1))
Range("B1:AG1").Copy
Range("B2").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
Columns(1).Delete
Rows(1).Delete
Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="=", FieldInfo:=Array( _
Array(1, 1), Array(2, 1))
ProcNum = .Trim(.Substitute(Range("B20").Value, Chr(34), ""))
ActiveSheet.Delete
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

Function DriveSerialNumber() As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
DriveSerialNumber = Format(CDbl(FSO.Drives("C:").SerialNumber))
End Function

Sub CompSpex()
Run "ProcessorNumber"
MsgBox "Processor number is: " & ProcNum & vbCrLf & "Hard drive serial number is: " & DriveSerialNumber
End Sub

 

[Johnpow]

Hi Tom,
On my 64bit WIN10 PC, the Hard Drive Serial Number displays but no Processor No.
Can you assist with a variation of your code which reads and displays Motherboard and Hard Drive serial numbers please?

 

[jimrward]

I have a script somewhere that does a bigger interrogation of a machine I may have even posted it on here I will take a look

See the following

https://www.mrexcel.com/forum/excel-questions/1054445-vba-collect-computer-attritbutes.html

 

[Johnpow]

Many thanks for speedy response Jimrward
I am not a VBA coder, but there has to be considerable knowledge of VBA to produce such Fantastic work – Thankyou.
Anyway, I decided to try two different PC in my office to collect some details.
Seems some manufacturers don’t allow some items to be accessed.

Here are my trials

PC #1 – Desktop – 64 bit WIN10
Some searching on the web, I used Command prompt process and got the below
wmic baseboard get serial number
Serial Number
.6AW5YTK4.CNPE10075V05JN.
While the VBA Code from here - https://www.mrexcel.com/forum/excel-questions/1054445-vba-collect-computer-attritbutes.html reveals the following part of the above
6AW5YTK4

PC #2 – Laptop-– 64 bit WIN10
wmic baseboard get serialnumber
SerialNumber
DFPTA013K2E9AK

While the VBA Code revealed:
SCD232393ZC6

So I am confused as to what is the real Serial No.

I am hoping to use with a locking process in EXCEL as published at:
http://www.yogeshguptaonline.com/2009/07/hardware-locking-for-excel-workbook.html

The code for accessing the MB S/n using Yogesh, seems to match what I can source from the WMIC process.
But I have an issue with how to edit part of his code.
In the Yogesh code, I don’t understand exactly what the Set line should look like.
I have sent several messages to Yogesh and published on website, but no responses.

The line of code I am hoping someone can assist with is this
Set RMBSN = Sheets(1).Range("C4") ' This is where you have already stored required MBSerialNumber
Where does the Serial Number actually go?
Are there specific characters that need to be placed either side of the Serial Number?
What should the Set code line finally look like exactly, character by character please?

 

[jimrward]

I put the code together years ago from vbscript snippets I found on the net I have a vbscript version but I translated it to excel via for convenience and also to see if I could. It was for an office refresh project from xp to win7 so it’s possible things were a bit more relaxed in those days some 8 years ago regarding motherboard credentials there were relevant details that we required so I didn’t check everything
It may be a bit of tweaking here and there is required plus it gives you a reasonable base to research anything you may require for your needs and incorporate even if you only find vbscript it is a reasonable template to modify and patch in

I am a programmer of all sorts and don’t claim to be a vbscript or vba expert so others may pick holes or improve it was learning project as well to produce the above

 

[mole999]

This might help for processor

PROCESSOR_IDENTIFIER	Intel64 Family 6 Model 58 Stepping 9, GenuineIntel
PROCESSOR_LEVEL	6
PROCESSOR_REVISION	3a09

<tbody>
</tbody>

which code snippet from VBAEXPRESS produces using ENVIRONS

Sub EnvironListing()
     'Note: Usage of Environ is limited to VBA only. This macro just creates a list of
     ' variables and their return value, to show you what VBA can return for you
     '
     'Example: The following line of code, when used in a macro, will create a messagebox
     '         with the username signed into the computer
     '   Msgbox Environ("username")
     ' Note: using      Msgbox Environ(31)       will return USERNAME=computerusername, where
     '  Msgbox Environ("username")      will return just the username
    Dim i As Integer, wb As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
     'To create a new workbook if nothing open, otherwise create a new sheet
    On Error Resume Next
    Set wb = ActiveWorkbook
    On Error GoTo 0
    If wb Is Nothing Then
        Workbooks.Add
    Else
        wb.Sheets.Add
    End If
    
     'Creates a list of environ arguments, in the form ARGUMENT=EnvironString
    i = 1
    Do Until Environ(i) = ""
        Cells(i, 1) = Environ(i)
        i = i + 1
    Loop
    
     'Separates the column into environ argument, and return value for that argument
    Range("A1:A" & i - 1).TextToColumns DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="="
    
     'Autofit columns for easier readability
    Columns.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub MsgBoxCompUserName()
    MsgBox Environ("username")
End Sub

 

[Johnpow]

Thank you for fast response
I also found that wmic baseboard get serial number produces a short number while - wmic bios get serial number produces a longer number

As I am not a VBA Coder, can you advise where in the below line I would place a serial number please?
Set RMBSN = Sheets(1).Range("C4")
An exact example please so I can do some testing.