[VB6]网卡物理地址修改器

Option Explicit

'****************************************************
'网络适配器 MAC 地址修改器
'日期：2010.08.28
'作者：TZWSOHO
'欢迎访问我的博客：
'http://blog.csdn.net/blog
'****************************************************

Private Const INVALID_HANDLE_VALUE As Long = -1&

Private Const NO_ERROR As Long = 0
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_MORE_DATA As Long = 234
Private Const ERROR_FILE_NOT_FOUND As Long = 2&
Private Const ERROR_INSUFFICIENT_BUFFER As Long = 122

Private Const ANY_SIZE As Long = 1
Private Const MAX_PATH As Long = 260
Private Const MAX_GUIDLEN As Long = 80

Private Const DIGCF_PRESENT As Long = &H2
Private Const DIGCF_ALLCLASSES As Long = &H4
Private Const DIGCF_DEVICEINTERFACE As Long = &H10

Private Const SPDRP_DEVICEDESC As Long = &H0
Private Const SPDRP_DRIVER As Long = (&H9)
Private Const SPDRP_CLASS As Long = (&H7)

Private Const LMEM_FIXED As Long = &H0
Private Const LMEM_ZEROINIT As Long = &H40
Private Const LPTR As Long = (LMEM_FIXED + LMEM_ZEROINIT)

Private Const DICS_ENABLE As Long = &H1
Private Const DICS_DISABLE As Long = &H2

Private Const DICS_FLAG_CONFIGSPECIFIC As Long = &H2

Private Const DIF_PROPERTYCHANGE As Long = &H12

Private Const HKEY_LOCAL_MACHINE As Long = &H80000002

Private Const REG_SZ As Long = 1

Private Const REG_OPTION_NON_VOLATILE As Long = 0

Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_CREATE_SUB_KEY As Long = &H4

Private Const REG_CREATED_NEW_KEY As Long = &H1

Private Const MAXLEN_PHYSADDR As Long = 8
Private Const MAXLEN_IFDESCR As Long = 256
Private Const MAX_INTERFACE_NAME_LEN As Long = 256

Private Const MIB_IF_ADMIN_STATUS_UP As Long = 1
Private Const MIB_IF_ADMIN_STATUS_DOWN As Long = 2

Private Type MIB_IFROW
wszName(MAX_INTERFACE_NAME_LEN - 1) As Integer
dwIndex As Long
dwType As Long
dwMtu As Long
dwSpeed As Long
dwPhysAddrLen As Long
bPhysAddr(MAXLEN_PHYSADDR - 1) As Byte
dwAdminStatus As Long
dwOperStatus As Long
dwLastChange As Long
dwInOctets As Long
dwInUcastPkts As Long
dwInNUcastPkts As Long
dwInDiscards As Long
dwInErrors As Long
dwInUnknownProtos As Long
dwOutOctets As Long
dwOutUcastPkts As Long
dwOutNUcastPkts As Long
dwOutDiscards As Long
dwOutErrors As Long
dwOutQLen As Long
dwDescrLen As Long
bDescr(MAXLEN_IFDESCR - 1) As Byte
End Type

Private Type MIB_IFTABLE
dwNumEntries As Long
table(ANY_SIZE - 1) As MIB_IFROW
End Type

Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type SP_DEVINFO_DATA
cbSize As Long
ClassDriver As Guid
DevInst As Long
Reserved As Long
End Type

Private Type SP_DEVICE_INTERFACE_DATA
cbSizeas As Long
InterfaceClassDriver As Guid
Flags As Long
Reserved As Long
End Type

Private Type SP_CLASSINSTALL_HEADER
cbSize As Long
InstallFunction As Long
End Type

Private Type SP_PROPCHANGE_PARAMS
ClassInstallHeader As SP_CLASSINSTALL_HEADER
StateChange As Long
Scope As Long
HwProfile As Long
End Type

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Declare Function GetVersion Lib "kernel32.dll" () As Long

Private Declare Function GetLastError Lib "kernel32.dll" () As Long

Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As Long

Private Declare Function StringFromGUID2 Lib "ole32.dll" (ByRef rguid As Guid, ByVal lpsz As String, ByVal cchMax As Long) As Long

Private Declare Function SetIfEntry Lib "IPHLPAPI.dll" (ByRef pIfRow As MIB_IFROW) As Long
Private Declare Function GetIfTable Lib "IPHLPAPI.dll" (ByRef pIfTable As Any, ByRef pdwSize As Long, ByVal border As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByRef phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByRef lpData As Any, ByRef lpcbData As Long) As Long

Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
Private Declare Function SetupDiChangeState Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA) As Long
Private Declare Function SetupDiEnumDeviceInfo Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal MemberIndex As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByRef ClassDriver As Any, ByRef Enumerator As Any, ByVal hwndParent As Long, ByVal Flags As Long) As Long
Private Declare Function SetupDiSetClassInstallParams Lib "setupapi.dll" Alias "SetupDiSetClassInstallParamsA" (ByVal DeviceInfoSet As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA, ByRef ClassInstallParams As Any, ByVal ClassInstallParamsSize As Long) As Long
Private Declare Function SetupDiGetDeviceInstanceId Lib "setupapi.dll" Alias "SetupDiGetDeviceInstanceIdA" (ByVal DeviceInfoSet As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA, ByVal DeviceInstanceId As String, ByVal DeviceInstanceIdSize As Long, ByRef RequiredSize As Long) As Long
Private Declare Function SetupDiGetDeviceRegistryProperty Lib "setupapi.dll" Alias "SetupDiGetDeviceRegistryPropertyA" (ByVal DeviceInfoSet As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA, ByVal Property As Long, ByRef PropertyRegDataType As Long, ByRef PropertyBuffer As Any, ByVal PropertyBufferSize As Long, ByRef RequiredSize As Long) As Long

Private bIsVista As Boolean, sPhyAddrLst() As String, sRegPath() As String, sNetCfg() As String

Private Sub cmdChange_Click()
On Error GoTo er
If lstAdapter.ListIndex < 0 Then Exit Sub

Dim dwDisposition As Long
Dim hkKey As Long, dwRst As Long
Dim RegType As Long, RegSize As Long
Dim hDevInfo As Long, DeviceInfoData As SP_DEVINFO_DATA
Dim sEnumerator As String, sNet As String, sTmp As String

'获取要修改的网卡地址
For dwRst = txtMAC.LBound To txtMAC.ubound
sNet = sNet & txtMAC(dwRst).Text
Next

'修改网卡地址注册表项：
'HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Class/{4D36E972-E325-11CE-BFC1-08002BE10318}/数字标识
If RegOpenKey(HKEY_LOCAL_MACHINE, sRegPath(lstAdapter.ListIndex), hkKey) = ERROR_SUCCESS Then
If (RegSetValueEx(hkKey, "NetworkAddress", 0, REG_SZ, ByVal sNet, Len(sNet)) <> ERROR_SUCCESS) Or _
(RegFlushKey(hkKey) <> ERROR_SUCCESS) Then
MsgBox "修改网卡地址失败！", vbCritical, "修改失败"
GoTo er
End If
End If

sEnumerator = Split(lstAdapter.Text, " ")(1) '获取网卡物理接口类型：PCI/USB
hDevInfo = SetupDiGetClassDevs(ByVal 0&, ByVal sEnumerator, 0, DIGCF_PRESENT Or DIGCF_ALLCLASSES)
If hDevInfo <> INVALID_HANDLE_VALUE Then
DeviceInfoData.cbSize = Len(DeviceInfoData)
If SetupDiEnumDeviceInfo(hDevInfo, lstAdapter.ItemData(lstAdapter.ListIndex), DeviceInfoData) Then
Dim PCP As SP_PROPCHANGE_PARAMS
PCP.ClassInstallHeader.cbSize = Len(PCP.ClassInstallHeader)
PCP.ClassInstallHeader.InstallFunction = DIF_PROPERTYCHANGE
PCP.Scope = DICS_FLAG_CONFIGSPECIFIC
PCP.StateChange = DICS_DISABLE '禁用网卡
PCP.HwProfile = 0
Call SetupDiSetClassInstallParams(hDevInfo, DeviceInfoData, PCP, Len(PCP))
Call SetupDiChangeState(hDevInfo, DeviceInfoData)

PCP.StateChange = DICS_ENABLE '重新启用网卡
Call SetupDiSetClassInstallParams(hDevInfo, DeviceInfoData, PCP, Len(PCP))
Call SetupDiChangeState(hDevInfo, DeviceInfoData)
End If
End If
MsgBox "网卡地址修改成功！", vbInformation, "修改成功"

'刷新列表框内的网卡地址
sTmp = "["
For dwRst = 0 To 5
sTmp = sTmp & Mid$(sNet, dwRst * 2 + 1, 2) & ":"
Next
sTmp = Left$(sTmp, Len(sTmp) - 1) & "] "
lstAdapter.List(lstAdapter.ListIndex) = sTmp & Split(lstAdapter.Text, " ", 2)(1)

er:
Call SetupDiDestroyDeviceInfoList(hDevInfo)
Call RegCloseKey(hkKey)
End Sub

Private Sub cmdRnd_Click()
Dim arrMAC(3) As Byte, i As Long
If bIsVista Then
'Windows 7 以上系统的 MAC 地址要求最高字节的低 4 位只能是：2、4、6、A、E
'参考：http://aswordok.blog.163.com/blog/static/321636642009428101632513/
arrMAC(0) = &H2: arrMAC(1) = &H6
arrMAC(2) = &HA: arrMAC(3) = &HE

Randomize Timer
vsMAC(0).Value = -CInt("&H" & Hex$(Rnd * 15) & Hex$(arrMAC(CInt(Rnd * 3))))
Else
Randomize Timer: vsMAC(0).Value = -CInt(Rnd * 255)
End If
For i = 1 To 5
Randomize Timer
vsMAC(i).Value = -CInt(Rnd * 255)
Next
End Sub

Private Sub Form_Load()
If App.PrevInstance Then End

'Windows 7 版本号为 6.1
'具体参照 MSDN：http://msdn.microsoft.com/en-us/library/ms724832(v=VS.85).aspx
bIsVista = ((((GetVersion And &HFFFF&) And &HFF&) > 5) And (((GetVersion And &HFFFF&) And &HFF00&) > 0))
If bIsVista Then vsMAC(0).SmallChange = 4: vsMAC(0).LargeChange = 4

Call EnumPhyAddr '获取网卡物理地址
Call ListAdapters("USB"): Call ListAdapters("PCI") '枚举 PCI/USB 两种物理接口的网卡
If lstAdapter.ListCount Then ReDim sPhyAddr(lstAdapter.ListCount - 1)

'窗体置屏幕中央
Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
End Sub

Private Sub lstAdapter_Click()
On Error GoTo er
Dim i As Long
Dim sTmp As String, sPhy() As String
lstAdapter.ToolTipText = lstAdapter.Text
'列表框文本格式：网卡物理地址 网卡物理接口类型 网卡名称描述
sTmp = Split(lstAdapter.Text, " ", 2)(0)
sPhy = Split(Mid$(sTmp, 2, Len(sTmp) - 2), ":")
For i = 0 To 5
vsMAC(i).Value = -CInt("&H" & sPhy(i))
Next
er:
End Sub

Private Sub vsMAC_Change(Index As Integer)
If Index = 0 Then
If bIsVista Then
If vsMAC(0).Value > -2 Then vsMAC(0).Value = -2
If vsMAC(0).Value < -&HFE Then vsMAC(0).Value = -&HFE
txtMAC(0).Text = Right$("0" & Hex$(-vsMAC(0).Value), 2)
Exit Sub
End If
End If
txtMAC(Index).Text = Right$("0" & Hex$(-vsMAC(Index).Value), 2)
End Sub

Private Sub ListAdapters(ByVal sEnumerator As String)
Dim hkKey As Long
Dim hDevInfo As Long, DataT As Long
Dim DeviceInfoData As SP_DEVINFO_DATA
Dim i As Long, j As Long, BufferSize As Long, RegCount As Long, RegType As Long
Dim sDriver As String, sClass As String, sDevice As String, sInstanceID As String, sNetCfgIID As String

hDevInfo = SetupDiGetClassDevs(ByVal 0&, ByVal sEnumerator, 0, DIGCF_PRESENT Or DIGCF_ALLCLASSES)
If hDevInfo <> INVALID_HANDLE_VALUE Then
DeviceInfoData.cbSize = Len(DeviceInfoData)
While SetupDiEnumDeviceInfo(hDevInfo, i, DeviceInfoData)

'Class 名为 Net 则为网络适配器
BufferSize = 0
Do While SetupDiGetDeviceRegistryProperty(hDevInfo, DeviceInfoData, SPDRP_CLASS, DataT, ByVal sClass, BufferSize, BufferSize) = 0
sClass = String$(BufferSize, vbNullChar)
Loop

'获取网络适配器的注册表相关信息路径
BufferSize = 128: sDriver = String$(BufferSize, vbNullChar)
Do While SetupDiGetDeviceRegistryProperty(hDevInfo, DeviceInfoData, SPDRP_DRIVER, DataT, ByVal sDriver, BufferSize, BufferSize) = 0
If GetLastError = ERROR_INSUFFICIENT_BUFFER Then
sDriver = String$(BufferSize * 2, vbNullChar)
Else
Exit Do
End If
Loop

'获取网络适配器名称描述
BufferSize = 0: sDevice = vbNullString
Do While SetupDiGetDeviceRegistryProperty(hDevInfo, DeviceInfoData, SPDRP_DEVICEDESC, DataT, ByVal sDevice, BufferSize, BufferSize) = 0
sDevice = String$(BufferSize, vbNullChar)
Loop

'获取网络适配器识别码，用于匹配网卡的物理地址
BufferSize = 128: sInstanceID = String$(BufferSize, vbNullChar)
Do While SetupDiGetDeviceInstanceId(hDevInfo, DeviceInfoData, sInstanceID, Len(sInstanceID), BufferSize) = 0
If GetLastError = ERROR_INSUFFICIENT_BUFFER Then
sInstanceID = String$(BufferSize * 2, vbNullChar)
Else
Exit Do
End If
Loop

If InStr(1, sClass, "Net", vbTextCompare) Then
'用 NetCfgInstanceId 匹配网卡物理地址索引
ReDim Preserve sRegPath(RegCount): RegCount = RegCount + 1
sRegPath(RegCount - 1) = "SYSTEM/CurrentControlSet/Control/Class/" & Left$(sDriver, InStr(1, sDriver, vbNullChar) - 1)
If RegOpenKey(HKEY_LOCAL_MACHINE, sRegPath(RegCount - 1), hkKey) = ERROR_SUCCESS Then
sNetCfgIID = String$(80, vbNullChar): BufferSize = 80
If RegQueryValueEx(hkKey, "NetCfgInstanceId", 0, RegType, ByVal sNetCfgIID, BufferSize) = ERROR_SUCCESS Then
sNetCfgIID = Left$(sNetCfgIID, InStr(1, sNetCfgIID, vbNullChar) - 1)
For j = 0 To UBound(sNetCfg)
If InStr(1, sNetCfg(j), sNetCfgIID, vbTextCompare) Then
Exit For
End If
Next
End If
End If
Call RegCloseKey(hkKey)

sClass = sClass & vbNullChar: sDriver = sDriver & vbNullChar: sDevice = sDevice & vbNullChar
If j < UBound(sNetCfg) + 1 Then
lstAdapter.AddItem sPhyAddrLst(j) & " " & sEnumerator & " " & _
Left$(sDevice, InStr(1, sDevice, vbNullChar) - 1)
Else
lstAdapter.AddItem "[未知] " & sEnumerator & " " & _
Left$(sDevice, InStr(1, sDevice, vbNullChar) - 1)
End If
lstAdapter.ItemData(lstAdapter.NewIndex) = i
End If
i = i + 1
Wend
Call SetupDiDestroyDeviceInfoList(hDevInfo)
lstAdapter.ToolTipText = "共发现 " & lstAdapter.ListCount & " 个网络适配器！"
End If
End Sub

Private Sub EnumPhyAddr()
Dim i As Long, j As Long
Dim sDeviceName As String, sPhyAddr As String
Dim IfRows() As MIB_IFROW, arrIfTable() As Byte
Dim lIfSize As Long, lIfRow As Long, PhyCount As Long, NetCfgCount As Long

'获取数据结构大小
ReDim arrIfTable(0): lIfSize = 1
Call GetIfTable(arrIfTable(0), lIfSize, False)

ReDim Preserve arrIfTable(lIfSize - 1)
If GetIfTable(arrIfTable(0), lIfSize, False) = NO_ERROR Then
CopyMemory lIfRow, arrIfTable(0), 4
If lIfRow Then
ReDim IfRows(lIfRow - 1)
For i = 0 To lIfRow - 1
CopyMemory IfRows(i), arrIfTable(4 + i * Len(IfRows(0))), Len(IfRows(0))

'获取 NetCfgInstanceId，用于匹配网卡物理地址
sDeviceName = String$(MAX_INTERFACE_NAME_LEN * 2, vbNullChar)
CopyMemory ByVal sDeviceName, IfRows(i).wszName(0), Len(sDeviceName)
sDeviceName = StrConv(sDeviceName, vbFromUnicode)

If IfRows(i).dwPhysAddrLen Then
sPhyAddr = ""
For j = 0 To IfRows(i).dwPhysAddrLen - 1
sPhyAddr = sPhyAddr & Right$("0" & Hex$(IfRows(i).bPhysAddr(j)), 2) & ":"
Next
sPhyAddr = "[" & Left$(sPhyAddr, Len(sPhyAddr) - 1) & "]"
Else
sPhyAddr = "[未知]"
End If
ReDim Preserve sPhyAddrLst(PhyCount): sPhyAddrLst(PhyCount) = sPhyAddr: PhyCount = PhyCount + 1
ReDim Preserve sNetCfg(NetCfgCount): NetCfgCount = NetCfgCount + 1
sNetCfg(NetCfgCount - 1) = Left$(sDeviceName, InStr(1, sDeviceName, vbNullChar) - 1)
Next
End If
End If
End Sub