VB - Network - GetMacAdresses

[blaff]

For a Project I wanted to get the MAC-Adress of a computer to check wether the program is licenced or not.
I found several possibilities all over the net, but all of them (all I found) had one major drawback: they didn't work without a network => very annoying for Laptop-users out of their office.

I wrote this solution using the command "ipconfig /all" which seems to work all the time (at least an windows version >= win2k).

You need the a reference to "Microsoft VBScript Regular Expressions 5.5".

Enjoy:

Private Function GetMacAdresses() As VBScript_RegExp_55.MatchCollection
Dim reg As VBScript_RegExp_55.RegExp
Dim fs As Object
Dim F As Object
Dim temppath As String
Dim resFilename As String, batFilename As String
Dim lret As Long
Dim result As String
 
    Set reg = New VBScript_RegExp_55.RegExp
    reg.Pattern = "..-..-..-..-..-.."
    
    On Error GoTo FailedLicence
    Set fs = CreateObject("Scripting.FilesystemObject")
    
    temppath = fs.GetSpecialFolder(2)
    resFilename = fs.Buildpath(temppath, "mac.txt")
    batFilename = fs.Buildpath(temppath, "ip.cmd")
    
    On Error Resume Next
    Set F = fs.opentextfile(batFilename, 8, True)
    F.writeline "ipconfig /all > " & resFilename
    F.Close
    
    If Err.Number <> 0 Then
        MsgBox "Schreiben der Batch-Datei fehlgeschlagen: " & Err.Description, vbCritical + vbOKOnly
        'frmDebugInfo.AddMessage "Schreiben der IP-Batch-Datei fehlgeschlagen: " & Err.Description
        Err.Clear
        Exit Function
    End If
    
    On Error GoTo 0
 
    ShellAndWait batFilename, 0, lret, "omw", temppath
 
    If lret <> 0 Then
        'frmDebugInfo.AddMessage "Ausführung der IP-Batch-Datei fehlgeschlagen."
        'Err.Clear
        Exit Function
    End If
    Set F = fs.opentextfile(resFilename, 1, False)
    
    result = F.readall
    F.Close
        
    fs.deletefile resFilename
    fs.deletefile batFilename
    
    Set F = Nothing
    Set fs = Nothing
    
    reg.IgnoreCase = True
    reg.Global = True
    reg.MultiLine = True
    
    Set GetMacAdresses = reg.Execute(result)
 
Exit Function
FailedLicence:
 
End Function

and

Option Explicit
 
 
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
       
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
 
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
 
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
 
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
 
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
 
 
'______________________________________________________________________
 
 
Public Function ShellAndWait(ByVal strPath As String, _
ByVal iWindowStyle As Integer, ByRef lreturnCode As Long, _
Optional sWinTitle As String = "", _
Optional sDirectoryPath As String = "") _
As Boolean
 
Dim proc As PROCESS_INFORMATION, bSuccess As Long
Dim start As STARTUPINFO
Dim ret As Long
 
 
 
On Error GoTo ShellAndWaiterr
 
' Initialize the STARTUPINFO structure:
start.cb = Len(start) ' you must set the size
start.dwFlags = &H1& ' STARTF_USESHOWWINDOW Use Show Window
start.wShowWindow = iWindowStyle
 
 
If Not IsMissing(sWinTitle) Then
   ' if there is a title set the window title
   start.lpTitle = sWinTitle
End If
 
' Start the shelled application:
ret = CreateProcessA(0&, strPath, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, _
sDirectoryPath, start, _
proc)
 
' Wait for the shelled application to finish:
ret = WaitForSingleObject(proc.hProcess, 100&)
Do While ret <> 0
   If ret < 0 Then
       ShellAndWait = False
       Exit Function
   End If
 
   DoEvents
 
   ret = WaitForSingleObject(proc.hProcess, _
       100&)
Loop
 
'get the return code
ret = GetExitCodeProcess(proc.hProcess, _
lreturnCode)
 
'close the process handles
ret = CloseHandle(proc.hProcess)
ShellAndWait = True
Exit Function
 
ShellAndWaiterr:
   ShellAndWait = False
   Exit Function
   Resume
End Function