Добрый день. Вроде не было подобного вопроса, можно ли узнать средствами VBA серийный номер (тот что закладывается производителем и обеспечивает уникальность) флешки? Файл с макросом будет находиться также на флешке. Подскажите пожалуйста.
Sub test()
DriveLetter$ = "c:"
SerialNumber$ = CreateObject("scripting.filesystemobject").GetDrive(DriveLetter$).SerialNumber
Signature$ = GetSignature(DriveLetter$)
MsgBox SerialNumber$
MsgBox Signature$
End Sub
Function GetSignature(Optional ByVal DriveLetter$ = "c:") As Long
On Error Resume Next: Dim v&, sv$, obj As Object, DriveID$, PartName$
With GetObject("winmgmts:")
For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID='" & DriveLetter$ & "'} WHERE AssocClass = Win32_LogicalDiskToPartition"): PartName$ = obj.DeviceID
Next
For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" & PartName$ & "'} WHERE AssocClass = Win32_DiskDriveToDiskPartition"): DriveID$ = obj.DeviceID
Next
For Each obj In .ExecQuery("SELECT * FROM Win32_DiskDrive WHERE DeviceID='" & Replace(DriveID$, "\", "\\") & "'"): GetSignature = Val(obj.Signature)
Next
End With
End Function
Sub TestSerialNumUSB()
Dim k
For Each k In USBGetCur
Debug.Print k
Next
End Sub
'функция извлечения информация о текущих флешках, возвращает двухмерный массив
'1-я размерность: серийный номер, наименование, объем, VID и PID
'2-я размерность: счетчик
Function USBGetCur()
On Error Resume Next
Dim wmiDiskDrive, wmiDiskDrives 'диски
Dim wmiUSBHub, wmiUSBHubs 'USB
Dim PnPID, PnPID2 'идентификатор флешки
Dim USBSNumb 'серийный номер
Dim arrUSBInfo() 'массив для информации о каждой флешке
Dim i 'счетчик
'переменные для 2-го способа извлечения VID-PID
Dim strComputer 'местный компьютер
Dim strValueName 'название параметра
Dim strKeyPath 'раздел с информацией об USB
Dim objReg 'реестр
Dim subkey, arrSubKeys, arrSubKeys1 'подключ и массивы подразделов
Dim ParIdPre ' переменная для параметра ParentIdPrefix
Const HKLM = &H80000002
Set wmiDiskDrives = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive") 'получаем диски
Set wmiUSBHubs = GetObject("winmgmts:").InstancesOf("Win32_USBHub") 'получаем USB
'значения для 2-го способа извлечения VID-PID
strComputer = "." 'местный компьютер"
strValueName = "ParentIdPrefix" 'название параметра"
strKeyPath = "SYSTEM\CurrentControlSet\Enum\USB" 'раздел с информацией об USB
Set objReg = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") 'получаем провайдера реестра
i = 0
For Each wmiDiskDrive In wmiDiskDrives 'побежали по дискам
If wmiDiskDrive.InterfaceType = "USB" Then 'если диск USB
ReDim Preserve arrUSBInfo(4, i) 'перебили размерность массива
arrUSBInfo(1, i) = wmiDiskDrive.Model 'модель диска
arrUSBInfo(2, i) = wmiDiskDrive.Size 'объем диска
PnPID = wmiDiskDrive.PnPDeviceID 'идентификатор флешки из реестра
'вытаскиваем серийный номер флешки
USBSNumb = Mid(PnPID, InStrRev(PnPID, " \ ") + 1) 'выбираем из строки-идентификатора серийник
arrUSBInfo(0, i) = Left(USBSNumb, Len(USBSNumb) - 2) 'удаляем последние 2 символа — типа &0 или &1
For Each wmiUSBHub In wmiUSBHubs 'побежали по USB
PnPID2 = wmiUSBHub.PnPDeviceID
'вытаскиваем серийник и сравниваем с серийником из Win32_DiskDrive
If Right(PnPID2, Len(PnPID2) - InStr(5, PnPID2, "\")) = arrUSBInfo(0, i) Then
arrUSBInfo(3, i) = Mid(PnPID2, 9, 4) 'вытаскиваем VID
arrUSBInfo(4, i) = Mid(PnPID2, 18, 4) 'вытаскиваем PID
Exit For
End If
Next
If IsEmpty(arrUSBInfo(3, i)) Then 'если не прокатило получить VID, тогда попробуем 2-й способ — через реестр
objReg.EnumKey HKLM, strKeyPath, arrSubKeys 'получаем подразделы
If IsArray(arrSubKeys) Then 'на всякий случай — если массив
For Each subkey In arrSubKeys 'для каждого подраздела
If Left(subkey, 3) = "Vid" Then 'если название раздела начинается с Vid — пропускаем ROOT_HUB и пр.
objReg.EnumKey HKLM, strKeyPath & " \ " & subkey, arrSubKeys1 'получаем подразделы подразделов"
If IsArray(arrSubKeys1) Then 'снова если массив
For Each subsubkey In arrSubKeys1 'для каждого подраздела подразделов
'получаем значение параметра ParentIdPrefix
objReg.GetStringValue HKLM, strKeyPath & " \ " & subkey & " \ " & subsubkey, strValueName, ParIdPre
'поднимем в верхний регистр ParentIdPrefix и сравним с серийным номером
If UCase(ParIdPre) = USBSNumb Then
arrUSBInfo(3, i) = Mid(subkey, 5, 4) 'вытаскиваем из строки VID и PID
arrUSBInfo(4, i) = Mid(subkey, 14, 4)
End If
Next
End If
End If
Next
End If
End If
i = i + 1
End If
Next
If i <> 0 Then
USBGetCur = arrUSBInfo 'если есть флешки
Else
USBGetCur = i
End If
End Function
Коллеги, а кто сказал что Signature = Serial Number? да тот же и ко второму коду вопрос , он совсем выдал для двух одинаковых по моделям выдал результат USBSTOR\DISK&VEN_JETFLASH&PROD_TRANSCEND_8GB&REV_1100\47ROU662NKWTGJ6W JetFlash Transcend 8GB USB Device 8101900800
USBSTOR\DISK&VEN_JETFLASH&PROD_TRANSCEND_8GB&REV_1100\48B4E970Y53LKGC3 JetFlash Transcend 8GB USB Device 8101900800 который никак не связан с серийником.
Evgenyy, по моей флешке этот код не выдал ничего похожего на серийный номер, в шестом столбце пусто USB 4096MB flash drive USB Device \\.\PHYSICALDRIVE2 3,761250973 А мой по ней же USBSTOR\DISK&VEN_4096MB&PROD_FLASH_DRIVE&REV_1.0\102315A74FD79E 4096MB flash drive USB Device 4038612480 по другой (ридер с картой): USBSTOR\DISK&VEN_MASS&PROD_STORAGE_DEVICE&REV_1.00\121220160204 Mass Storage Device USB Device 64017354240 Вроде есть что-то похожее на серийник.
Function GetSerial(Optional ByVal DriveLetter$ = "c:") As String
On Error Resume Next
Dim obj As Object, PartName$
With GetObject("winmgmts:")
For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID='" & DriveLetter$ & _
"'} WHERE AssocClass = Win32_LogicalDiskToPartition")
PartName$ = obj.DeviceID
Next
For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" & PartName$ & _
"'} WHERE AssocClass = Win32_DiskDriveToDiskPartition")
GetSerial = Replace(Mid(obj.PNPDeviceID, InStrRev(obj.PNPDeviceID, "\") + 1), "&0", "")
Next
End With
End Function
Как минимум на двух разных машинах выдает одинаковый код для одной флэхи и разный для разных, даже близнецов.
БМВ, правильно я понимаю, что для получения с помощью данной функции серийного номера устройства нужно имя диска. То есть у меня например флешка обозначается на устройстве, как F:, соответственно я прописываю:
Код
Function GetSerial(Optional ByVal DriveLetter$ = "F:") As String
Кстати забавно, я подключил жесткий диск и флешку и в случае жесткого диска ваша функция и функция, которая была здесь выдали одинаковый результат серийника. А вот с флешкой разные номера.
Но ваша функция соответствует информации в реестре, который выдает виндовс.
На моей флешке эта функция выдаёт 102315A74FD79E Что совпадает с тем, что я уже публиковал выше: USBSTOR\DISK&VEN_4096MB&PROD_FLASH_DRIVE&REV_1.0\102315A74FD79E но почищенное Но нужно указывать диск! А в том монстре не нужно.
Объединил оба метода, правда он выводит строку содержащую список номеров USB дисков разделенных точка запятой и пробелом
Код
Function USBDiskSerial()
Dim wmiDiskDrive, wmiDiskDrives, строка, serial, i
On Error Resume Next 'если ошибка продолжаем
Set wmiDiskDrives = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive") 'получаем диски
i = 0 'обнуляем счетчик
For Each wmiDiskDrive In wmiDiskDrives 'побежали по дискам
If wmiDiskDrive.InterfaceType = "USB" Then 'если диск USB
serial = Replace(Mid(wmiDiskDrive.PnPDeviceID, InStrRev(wmiDiskDrive.PnPDeviceID, "\") + 1), "&0", "") 'получаем только серийный номер
If Not serial = vbNullString Then строка = строка & IIf(строка <> vbNullString, "; ", vbNullString) & serial 'добавляем его в конец строки
i = i + 1 'счетчику прибавляем 1
End If
Next
If i <> 0 Then 'если счетчик не равен 0
USBDiskSerial = строка 'присваиваем строку
Else
USBDiskSerial = vbNullString 'иначе пустая строка
End If
End Function
но получить массив из него просто: массив = Split (USBDiskSerial, "; ")
ну и проверить смонтирована ли нужная флешка, если даже смонтировано много флешек тоже легко:
Код
Sub test()
If InStr(1, USBDiskSerial, "102315A74FD79E") > 0 Then Debug.Print "Флешка установлена" ' "102315A74FD79E" - серийный номер флешки
End Sub