Страницы: 1
RSS
Узнать серийный номер флешки через VBA
 
Добрый день.
Вроде не было подобного вопроса, можно ли узнать средствами VBA серийный номер (тот что закладывается производителем и обеспечивает уникальность) флешки? Файл с макросом будет находиться также на флешке.
Подскажите пожалуйста.
Изменено: DopplerEffect - 08.05.2020 13:33:04
 
Что-то нагуглил, подкрутил... Не, ниже вроде лучше нагуглил :)
Изменено: Hugo - 08.05.2020 14:47:35
 
Код
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
 
Игорь, у меня как-то с флешками не взлетело...
Но вот что-то рабочее:
Скрытый текст
 
Коллеги, а кто сказал что Signature = Serial Number?  да  тот же и ко второму коду вопрос , он совсем выдал для двух одинаковых по моделям выдал результат
USBSTOR\DISK&VEN_JETFLASH&PROD_TRANSCEND_8GB&REV_1100\47ROU6­62NKWTGJ6W
JetFlash Transcend 8GB USB Device
8101900800

USBSTOR\DISK&VEN_JETFLASH&PROD_TRANSCEND_8GB&REV_1100\48B4E9­70Y53LKGC3
JetFlash Transcend 8GB USB Device
8101900800
который никак не связан с серийником.
Изменено: БМВ - 08.05.2020 15:18:18
По вопросам из тем форума, личку не читаю.
 
У меня код Игоря выдает одинаковые цифры не зависимо от того, какие устройства подключены или нет. А код Hugo не запустился
 
Посмотрите здесь есть информация по теме.
 
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
Вроде есть что-то похожее на серийник.
 
У меня выдал следующую информацию
USBsilicon-power USB Device\\.\PHYSICALDRIVE17,45E69B0400FFFF0D6[img]data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAooAAAASCAYAAADc3v+LAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAAA07SURBVHhe7Zw7diI7EIbLdy0wgQ8raFYAThw5ddaEkDgjJHMCocmcOprEzQpgBRwH0+yF+1dJatRC6ofxA2N952hmGj1aKkmlUkk9V3tAkUgkEolEIpGIw3/670hLrq6uJEQiP4U4ZiMh4tj42cT+i3wGZlxFQzESiUQikUgk4iUaipFIJBKJRCIRL19rKO4W1L8a0Uo/Fhz9vqNFX7k8izCyckl6J15CnxY7neYsMe0yba17joRZ0Yj73B4XIfntkNYeT33EF+NEl+MGpAmPJX+ePuryMcPva8fBanRFthjdZ5ej+CbzsXbu6zb3Fx4ZKnn3D4Vp+VjBrpDvXW4dQw1cjRDv0SOh+jNu2Toc6gsCaUp9XLxDty9QR5a/xAXL5OCpa1UbfiLSV8dtL8ndh08Oriy94/CCQfvRcE/oI06n4X+M8Gx+t+WMvijyjFBWAaRclGUF6NeSgPn9GPPeOIN5hzPXg/mCcYE6cZCiPzsetK3bkS5ABm9f2L8jhGTZkrP0KK5GXZr0MuLvbFTIab4dOoozpayI1yHr0aR7QYow8gFg0b0f0tKMlzyjdLOk4b2zEKTWeNNpaseSlSfP5kTLIXUDi/s5M7hNafvvIA332cUfH5qPTTdvHRqvWe4Tuncy7BYzWiZzeh535LmZfrBgg6L7RtPa9BgrM4yUFPV+bNuPbvsz6k26jtFyLKMsxVg8Mkogi2mK8fTXM/5W9HeJkm4H+tkjdwlPZFIoYGx3J7TRTxfB4Knc5gwygzymepyEWD165JC/0cbWAesxeuEXAhlAAFZY83AEGKH9LtH2Tv2eQoKTR2WEsAE3xKCc54hD2E6Q1jYWgV0u9CtBv0JZ6kgUco88mNOSH9oaSkBFFSAN5maZqnwNyoROObRTB3vSfFp8g7rZ8tJry8FYRP5gX+DvJZ6lLxDXQ9nQwRJ3AmdoKLIiTGj+YEscivN5TolXcVoMbqEmtlSxxn0zvBiyInKVuKEuPtKenN5kVbgmTC2IeEBPmECVCwHSwBYCzcdSZzAmXttpOWtoGFXxxeOge0308nrQJe6zS128YfBA82RDb6wLG4G+wWK/gdIr5jl23qxT58+mv9rqBxhIWMTSzJalSe/01e6VXjYp3T5c1+uaWjxt8TB4QD02bxilDqLLlvTXzbz6i19RxxYDY7fo09XVkLZpSon+7fLw9bMHGDXDbXIkhxWs7+RaNETEB+aGWNd3N+r5iY2YJ55KRP+2+AMSveEHhDv8e/MSNk6gXzGEAfJxGlO2yD+Qnw0g0eMWVfmalPldtK0b1haRF/RVqW2+vsDmSQxEs1mShQyJG+tgP2doKHbpGovL0Y6+M6Z13cLJSjSdFjL6Pna0GLFy1kch1k6g+kjRE4+F0j42PZQFdqvye7CLOzpS7Y+sNP2KI8VD+lEofcX75DgM6c3CqxYnLs94S0zbdBouq2+VNbK9KqYufbyD4z/AS8yeKjTm8I4KUDf22lByp3RfQ9jTxpOyMIyCbfT3Mx99KQ/UO8ZBUJYN6NzQHb3Qq8nkPrvUxZ8CFJ142aR9kIOyEq053VI/hAwrSb8u6Yrd6wtt0lsaIG6KOsxOtfhP2riqzcrSsRTFoJk/VOtBlz9TyrF4rGEAXyrG61zaPxyB8YS1Nnu+08+GHWydBOvuty8c50v+pv7+45GR2okf+NPDHxXGCfQVO9FYv4px45Z9lB8TiL2JCQwqm6p8tWV+I++pm23wVfWFiyxkp3OGhiJ7UzJKl8Ni4fMfKWExMfEmYEd5DrvC3eKeJssNdrd7yucJbdAWbxNqgcHUndCyl4miz9lDgbKUMcFxQ7ynR1m+Jz4uvaMJDd3j0g12bQ9rbDIgUwy05azGiOAjgdtnpM/FG7QcGuOv+n1lI2lHry8Y1IzxlmAXJD+J8aXLQgmmrN5yQl33CA7p755P9awN6AF9wLDsumz8LjwGoz3eUDeMJEqnN6LH2qKOZavaiDGu3I+Fx0iMFLzTv1g1GAd1sqykQzfQ2S8HS9F5dqmL16weacIeuqLzPHPWcxw6eFLzv9/HPKLDkbOiqX6wSLQ3uZIVPbJNqi0NHs+bJl7TSpRRW+VRlWNQNk71s43MqZJnU3lTy2PEI1NHJp3BAFK7ZJS+SafVx8Wsl1/ufEa2OnV4uTfya3pd4gLBvIIArDtu+kjUeA3/WvfizBAzRozoAwRjnNg7JLtc6CspC/pVkLI9mPziTeT0joFfla+uzO/klLoVbQv0hQ1fCZCuQNoTzaKzvKPIi7scD0qwFoXSguC5m5PPiSb3ZzPJl7M+Pf55lsX96T2WjnhD0FKstKwAO/pOzpoXTh0n3gUVWRgfJU9I4RXjRQt/+Y65bGRXLgXq8vRCV/c+8Z7giS0fYxQKyhhShhBXB8aXKQv/NmWJMbdxvFQtPXohOuO1GFfcfG7PcgKD0TWk7PtJhZHcfaeBD+raaMtLL3TB9jYZB3WyrKGjLL9CJu6zy3G8b+O2pXluG/n+Oav6xUYf20IkhyNnmyb6oSUsR1v+3D+bCbW+qljJsYxm1zntQ8pBju6t42e3jkLgjuK7FM4PRfRN3XE8NgIvd86mQ7P7x4egelPKYUpvv/Wuu3tHcT3WEQxr8Cl+x4LA9+KG+u4bH3fOoc0msEau7vHD8Ywul4v80K8E/VovZCSQ+4/PJxs7R2B+YxIegjGKDZ8dfxKBvjDwxzIsNyZFOs+wb8OZGoo2elHgBaXu/lfnD/WMYfONdMZTSnmuYKVjY6PLx79V9Q6wC+08gInrNXE/nwh7yOrfp+/1sQckf1NG4Zy9mMoYUh5GddHclLWBYjELZnfC8Z/Xd2xcrTGpMig0UWOVRoAxko13sB0so/o2WvLShrUY0Rzl0GQcnCxLnjv2JsJ9djmK9xks5aPdVnSv0U+9BqcrDfRD3eYIGpY/YuEx0dUy5Dt9rGbdo992sKcqUVeRBEtG2kCunr/suU2KOsixc2CM/GaKKwP62cdqNMS6GvA4eq4htLmf/CuQ41Eg1jgEZbyIZmKN9d04/vjlVqcNjm38rvWrCNmU7cL5+a4AryI+RVKVryrO4H5sUjKKwWfFN6lbCLttob5gI7ELI1VA3AdsGr/WUBRDzjMB2bAwx0P8haLvThrfi6o5xlHYivm7wOK13lOeZ9hoYTngL2jf4ZrohAYUMHHvMWQEkbNeFF3vmgMvZk3ep46ftzSTr9P4iEwbQ9uZ8jBqZW7KSuY55o8xKlRoPaa3/yrrXqZDAyi0Z30U/dHwQm7GX5M2KnktaXZfdezcbBycLkvuK/vjCffZpS7+k2irH0IfhaAEvgcrTkjtkfJ6O0/5OEm8vQFjl42TDDUrrnb4Yc+tfFgD5T9b1n/R+xvJ3zB7KpW+unO8HGp9J9cdlHf3FCf0r4I/YGuKbF6hY9uuw2ZtKfLjWRYOdB76qjB++Bjb7rijfOpRqIr7btrUTa8tkqayL1Am3+sWkD6HAf8BfLFHkReXDU1K/zUJFDbfLTQ7ZX3c4v6XEXLvj6ovK6sLzR9zXHkK6kOOPr2iveMHKHr89q67k+Z40twr1Mad3E3TcfJVJUfyBw1ioDVcTPTxpQTsdIoc4mmTAovyZOPS5H3iBdrIkaE5RhVjCD8oO7GwkFRZL6/6Yxi8q/VHK9oILeoLzJG37V0wBjEUi0pl7k9WHVXtCqOv8QV3Wcjxt/mYqkkbZayzeFCfqnHbZBycJEsF95XtQXOfXeriP4XW+kEdxZcNMpbRsPj4IXhPUD5q2dTfxfSi9dq84sMTzMHsSB86iAGsNxM1XrPfCX+IUueZta8q6A0AZg1vDGQz5W4++Cj6DNaRswLjUBYyM99tw2W1UIacTDAE1q+Vx51IY/LLIvGgypZdns4P+VMHcWvLI4d+E/gYmzsumA+PVXHfTdu6sYdQry2SprIvrK/DM/NfG30AmDhfDjbS6PVDSOa5jjngpoHG3Rep8vkeYinHS0j3mPxfgnmnn3w/T5MiTZKauuP3xK5n3TNAW1P5zZSV6bJAnpXfAxllRWS2hwFhyc1TdgmTPrXKTPalrql8H2PeYfVp0VfOe1GW3S5+b7juIXKMk0N95L22fDT5PC2PF26j+66jkOxRVABfngRtdt5d2UZFPlf1L7+r/Tioew9j4sNwu+x+OjzzfDyepzpe+tjO5yGUpu3vmnr94OTN0nL6QuDcBmec20g+lCVlWvl1EJkE4kp9GmwPvx/pOXEoja57eYyAwHtN8Kf3y9Tk+XmE+88/ZoFHDmYequCX0Tlzcv9BJijAHwph4B/QM+r3xPodQA8X6bHeHUAi83spOPn5/aZs6K8jJc6YOtoDuypfME7XCTrDz2fHg7q6lQJkhbWlDJ59fYExf5wfIajgqjHj6ko/RFrCHh3mcsTHR3HKy5LbHsbIxXB5YzbyUVzk2NgtaPR6Q0+/4Lg+zu3IZ2DG1Q/4mCUSiUQikXbsXt/oOp4fRyInEw3FSCQSiVwcnfHT+7+6j0QiBXL0bNyLkUgkEolEIpGIguh/DC4MmRdwQocAAAAASUVORK5CYII=[/img]
 
Тут серийник есть. А у меня нет - значит не надёжно, не все флешки опознаёт.
 
Цитата
Hugo написал:
Вроде есть что-то похожее на серийник.
трудно сказать, по идее есть  в Win32_DiskDrive именно SerialNumber
Но судя по всему не всегда он прописан и может быть одинаков
Изменено: БМВ - 08.05.2020 16:40:21
По вопросам из тем форума, личку не читаю.
 
Я видел у себя название SerialNumber, но на моей флешке в value пусто....
 
а вот пример двух одинаковых и серийными разными


изыскания дают следующю. модификацию
Код
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


Как минимум на двух разных машинах выдает одинаковый код для одной флэхи и разный для разных, даже близнецов.
Изменено: БМВ - 08.05.2020 17:43:49
По вопросам из тем форума, личку не читаю.
 
БМВ, правильно я понимаю, что для получения с помощью данной функции серийного номера устройства нужно имя диска. То есть у меня например флешка обозначается на устройстве, как F:, соответственно я прописываю:
Код
Function GetSerial(Optional ByVal DriveLetter$ = "F:") As String
Кстати забавно, я подключил жесткий диск и флешку и в случае жесткого диска ваша функция и функция, которая была здесь выдали одинаковый результат серийника. А вот с флешкой разные номера.

Но ваша функция соответствует информации в реестре, который выдает виндовс.
Изменено: DopplerEffect - 09.05.2020 09:03:01
 
На моей флешке эта функция выдаёт 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
Изменено: rustym - 06.01.2023 13:49:57
Страницы: 1
Наверх