Controlar el uso de memorias USB

[josp24]

Hola, para mi proyecto de residencia profesional me pidieron que realizara un software en Visual Basic 6 que pudiera restringir el uso de memorias USB solo para personal autorizado. Es decir, que cuando alguien introduzca una memoria USB a una PC le pida nombre de usuario y contraseña para que pueda utilizarla (leer y escribir en ella), si no rechazarla automáticamente. Ojala y alguien pudiera ayudarme ya que estado buscando y no encuentro nada que me pueda servir. De antemano muchas gracias.

[aaronduran2]

La siguiente clase permite detectar la introducción/extracción de unidades USB. De ese modo, podrías hacer que:

- El programa está cargado.
- Introduces la unidad USB.
- El programa la detecta y pregunta por el usuario y la contraseña.
- Si son correctos continúa, en caso contrario bloquea la unidad (la forma de hacerlo a tu elección)

Está dividida en dos debido al tamaño máximo de los post.

Créditos a Cobein.

Código (vb) [Seleccionar] Expandir


'---------------------------------------------------------------------------------------
' Module      : cUSB_Detection
' DateTime    : 19/06/2008 18:17
' Author      : Cobein
' Mail        : cobein27@hotmail.com
' WebPage     : http://cobein27.googlepages.com/vb6
' Purpose     : Simple USB device detection
' Usage       : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
'
' Reference   : http://msdn.microsoft.com/en-us/library/aa363205(VS.85).aspx
'
' TODO        : Expand capabilities to support all WM_DEVICECHANGE message params and types
'
' Important   : The class is pre-filtering drives by bustype = USB
'
' History     : 19/06/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit

Private Const IDX_INDEX             As Long = 2     'index of the subclassed hWnd OR hook type
Private Const IDX_CALLBACKORDINAL   As Long = 22    ' Ubound(callback thunkdata)+1, index of the callback

Private Const IDX_WNDPROC           As Long = 9     'Thunk data index of the original WndProc
Private Const IDX_BTABLE            As Long = 11    'Thunk data index of the Before table
Private Const IDX_ATABLE            As Long = 12    'Thunk data index of the After table
Private Const IDX_PARM_USER         As Long = 13    'Thunk data index of the User-defined callback parameter data index
Private Const IDX_UNICODE           As Long = 75    'Must be Ubound(subclass thunkdata)+1; index for unicode support
Private Const ALL_MESSAGES          As Long = -1    'All messages callback
Private Const MSG_ENTRIES           As Long = 32    'Number of msg table entries. Set to 1 if using ALL_MESSAGES for all subclassed windows

Private Const IOCTL_STORAGE_BASE    As Long = &H2D
Private Const METHOD_BUFFERED       As Long = 0
Private Const FILE_ANY_ACCESS       As Long = 0
Private Const GENERIC_READ          As Long = &H80000000
Private Const FILE_SHARE_READ       As Long = &H1
Private Const OPEN_EXISTING         As Long = 3
Private Const FILE_SHARE_WRITE      As Long = &H2
Private Const INVALID_HANDLE_VALUE  As Long = (-1)

Private Const WM_DEVICECHANGE       As Long = &H219
Private Const DBT_DEVICEARRIVAL     As Long = &H8000&
Private Const DBT_DEVICEREMOVECOMPLETE As Long = &H8004&
Private Const DBT_DEVTYP_VOLUME     As Long = &H2
Private Const DBTF_MEDIA            As Long = &H1

Private Enum eThunkType
    SubclassThunk = 0
    HookThunk = 1
    CallbackThunk = 2
End Enum

Private Enum eMsgWhen
    MSG_BEFORE = 1
    MSG_AFTER = 2
    MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER
End Enum

Enum eDriveType
    DRIVE_UNKNOWN
    DRIVE_NO_ROOT_DIR
    DRIVE_REMOVABLE
    DRIVE_FIXED
    DRIVE_REMOTE
    DRIVE_CDROM
    DRIVE_RAMDISK
End Enum

Private Enum STORAGE_PROPERTY_ID
    StorageDeviceProperty = 0
    StorageAdapterProperty
End Enum

Private Enum STORAGE_QUERY_TYPE
    PropertyStandardQuery = 0
    PropertyExistsQuery
    PropertyMaskQuery
    PropertyQueryMaxDefined
End Enum

Enum STORAGE_BUS_TYPE
    BusTypeUnknown = 0
    BusTypeScsi
    BusTypeAtapi
    BusTypeAta
    BusType1394
    BusTypeSsa
    BusTypeFibre
    BusTypeUsb
    BusTypeRAID
    BusTypeMaxReserved = &H7F
End Enum

Private Type DEV_BROADCAST_HDR
    dbch_size                       As Long
    dbch_devicetype                 As Long
    dbch_reserved                   As Long
End Type

Private Type DEV_BROADCAST_VOLUME
   dbcv_size                        As Long
   dbcv_devicetype                  As Long
   dbcv_reserved                    As Long
   dbcv_unitmask                    As Long
   dbcv_flags                       As Integer
End Type

Private Type STORAGE_PROPERTY_QUERY
    PropertyId                      As STORAGE_PROPERTY_ID
    QueryType                       As STORAGE_QUERY_TYPE
    AdditionalParameters(0)         As Byte
End Type

Private Type OVERLAPPED
    Internal                        As Long
    InternalHigh                    As Long
    offset                          As Long
    OffsetHigh                      As Long
    hEvent                          As Long
End Type

Private Type STORAGE_DEVICE_DESCRIPTOR
    Version                         As Long
    Size                            As Long
    DeviceType                      As Byte
    DeviceTypeModifier              As Byte
    RemovableMedia                  As Byte
    CommandQueueing                 As Byte
    VendorIdOffset                  As Long
    ProductIdOffset                 As Long
    ProductRevisionOffset           As Long
    SerialNumberOffset              As Long
    BusType                         As STORAGE_BUS_TYPE
    RawPropertiesLength             As Long
    RawDeviceProperties(0)          As Byte
End Type

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallWindowProcW Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SendMessageA Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SendMessageW Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowLongW Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private c_lhWnd                     As Long
Private z_IDEflag                   As Long         'Flag indicating we are in IDE
Private z_ScMem                     As Long         'Thunk base address
Private z_scFunk                    As Collection   'hWnd/thunk-address collection
Private z_hkFunk                    As Collection   'hook/thunk-address collection
Private z_cbFunk                    As Collection   'callback/thunk-address collection

Public Event DriveArrival(ByVal sDrive As String, ByVal lDriveType As eDriveType)
Public Event DriveRemoval(ByVal sDrive As String)

Private Sub Class_Initialize()

    c_lhWnd = CreateWindowEx(0, "STATIC", 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
   
    If Not c_lhWnd = 0 Then
        If ssc_Subclass(c_lhWnd, , 1) Then
            Call ssc_AddMsg(c_lhWnd, WM_DEVICECHANGE, MSG_AFTER)
        Else
            Call DestroyWindow(c_lhWnd): c_lhWnd = 0
        End If
    End If
End Sub

Private Sub Class_Terminate()
    Call ssc_Terminate
    Call DestroyWindow(c_lhWnd)
    c_lhWnd = 0
End Sub

'-The following routines are exclusively for the ssc_subclass routines----------------------------
Private Function ssc_Subclass(ByVal lng_hWnd As Long, _
       Optional ByVal lParamUser As Long = 0, _
       Optional ByVal nOrdinal As Long = 1, _
       Optional ByVal oCallback As Object = Nothing, _
       Optional ByVal bIdeSafety As Boolean = True, _
       Optional ByVal bUnicode As Boolean = False) As Boolean 'Subclass the specified window handle

    ' \\LaVolpe - reworked routine a bit, revised the ASM to allow auto-unsubclass on WM_DESTROY
    Dim z_Sc(0 To IDX_UNICODE) As Long                 'Thunk machine-code initialised here
    Const CODE_LEN      As Long = 4 * IDX_UNICODE      'Thunk length in bytes
   
    Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES))  'Bytes to allocate per thunk, data + code + msg tables
    Const PAGE_RWX      As Long = &H40&                'Allocate executable memory
    Const MEM_COMMIT    As Long = &H1000&              'Commit allocated memory
    Const MEM_RELEASE   As Long = &H8000&              'Release allocated memory flag
    Const IDX_EBMODE    As Long = 3                    'Thunk data index of the EbMode function address
    Const IDX_CWP       As Long = 4                    'Thunk data index of the CallWindowProc function address
    Const IDX_SWL       As Long = 5                    'Thunk data index of the SetWindowsLong function address
    Const IDX_FREE      As Long = 6                    'Thunk data index of the VirtualFree function address
    Const IDX_BADPTR    As Long = 7                    'Thunk data index of the IsBadCodePtr function address
    Const IDX_OWNER     As Long = 8                    'Thunk data index of the Owner object's vTable address
    Const IDX_CALLBACK  As Long = 10                   'Thunk data index of the callback method address
    Const IDX_EBX       As Long = 16                   'Thunk code patch index of the thunk data
    Const GWL_WNDPROC   As Long = -4                   'SetWindowsLong WndProc index
    Const WNDPROC_OFF   As Long = &H38                 'Thunk offset to the WndProc execution address
    Const SUB_NAME      As String = "ssc_Subclass"     'This routine's name
   
    Dim nAddr         As Long
    Dim nID           As Long
    Dim nMyID         As Long

    If IsWindow(lng_hWnd) = 0 Then                      'Ensure the window handle is valid
        zError SUB_NAME, "Invalid window handle"
        Exit Function
    End If
   
    nMyID = GetCurrentProcessId                         'Get this process's ID
    GetWindowThreadProcessId lng_hWnd, nID              'Get the process ID associated with the window handle
    If nID <> nMyID Then                                'Ensure that the window handle doesn't belong to another process
        zError SUB_NAME, "Window handle belongs to another process"
        Exit Function
    End If
     
    If oCallback Is Nothing Then Set oCallback = Me     'If the user hasn't specified the callback owner
   
    nAddr = zAddressOf(oCallback, nOrdinal)             'Get the address of the specified ordinal method
    If nAddr = 0 Then                                   'Ensure that we've found the ordinal method
        zError SUB_NAME, "Callback method not found"
        Exit Function
    End If
       
    z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
   
    If z_ScMem <> 0 Then                                  'Ensure the allocation succeeded
 
        If z_scFunk Is Nothing Then Set z_scFunk = New Collection 'If this is the first time through, do the one-time initialization
        On Error GoTo CatchDoubleSub                              'Catch double subclassing
        z_scFunk.Add z_ScMem, "h" & lng_hWnd                    'Add the hWnd/thunk-address to the collection
        On Error GoTo 0
       
        ' \\Tai Chi Minh Ralph Eastwood - fixed bug where the MSG_AFTER was not being honored
        ' \\LaVolpe - modified thunks to allow auto-unsubclassing when WM_DESTROY received
        z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(16) = &H12345678: z_Sc(17) = &HF63103FF: z_Sc(18) = &H750C4339: z_Sc(19) = &H7B8B4A38: z_Sc(20) = &H95E82C: z_Sc(21) = &H7D810000: z_Sc(22) = &H228&: z_Sc(23) = &HC70C7500: z_Sc(24) = &H20443: z_Sc(25) = &H5E90000: z_Sc(26) = &H39000000: z_Sc(27) = &HF751475: z_Sc(28) = &H25E8&: z_Sc(29) = &H8BD23100: z_Sc(30) = &H6CE8307B: z_Sc(31) = &HFF000000: z_Sc(32) = &H10C2610B: z_Sc(33) = &HC53FF00: z_Sc(34) = &H13D&: z_Sc(35) = &H85BE7400: z_Sc(36) = &HE82A74C0: z_Sc(37) = &H2&: z_Sc(38) = &H75FFE5EB: z_Sc(39) = &H2C75FF30: z_Sc(40) = &HFF2875FF: z_Sc(41) = &H73FF2475: z_Sc(42) = &H1053FF24: z_Sc(43) = &H811C4589: z_Sc(44) = &H13B&: z_Sc(45) = &H39727500:
        z_Sc(46) = &H6D740473: z_Sc(47) = &H2473FF58: z_Sc(48) = &HFFFFFC68: z_Sc(49) = &H873FFFF: z_Sc(50) = &H891453FF: z_Sc(51) = &H7589285D: z_Sc(52) = &H3045C72C: z_Sc(53) = &H8000&: z_Sc(54) = &H8920458B: z_Sc(55) = &H4589145D: z_Sc(56) = &HC4816124: z_Sc(57) = &H4&: z_Sc(58) = &H8B1862FF: z_Sc(59) = &H853AE30F: z_Sc(60) = &H810D78C9: z_Sc(61) = &H4C7&: z_Sc(62) = &H28458B00: z_Sc(63) = &H2975AFF2: z_Sc(64) = &H2873FF52: z_Sc(65) = &H5A1C53FF: z_Sc(66) = &H438D1F75: z_Sc(67) = &H144D8D34: z_Sc(68) = &H1C458D50: z_Sc(69) = &HFF3075FF: z_Sc(70) = &H75FF2C75: z_Sc(71) = &H873FF28: z_Sc(72) = &HFF525150: z_Sc(73) = &H53FF2073: z_Sc(74) = &HC328C328
       
        z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
        z_Sc(IDX_INDEX) = lng_hWnd                                               'Store the window handle in the thunk data
        z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
        z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
        z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
        z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
        z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
       
        ' \\LaVolpe - validate unicode request & cache unicode usage
        If bUnicode Then bUnicode = (IsWindowUnicode(lng_hWnd) <> 0&)
        z_Sc(IDX_UNICODE) = bUnicode                                            'Store whether the window is using unicode calls or not
       
        ' \\LaVolpe - added extra parameter "bUnicode" to the zFnAddr calls
        z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree", bUnicode)           'Store the VirtualFree function address in the thunk data
        z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr", bUnicode)        'Store the IsBadCodePtr function address in the thunk data
       
        Debug.Assert zInIDE
        If bIdeSafety = True And z_IDEflag = 1 Then                             'If the user wants IDE protection
            z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode", bUnicode)                'Store the EbMode function address in the thunk data
        End If
   
        ' \\LaVolpe - use ANSI for non-unicode usage, else use WideChar calls
        If bUnicode Then
            z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcW", bUnicode)          'Store CallWindowProc function address in the thunk data
            z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongW", bUnicode)           'Store the SetWindowLong function address in the thunk data
            z_Sc(IDX_UNICODE) = 1
            RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
            nAddr = SetWindowLongW(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
        Else
            z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA", bUnicode)          'Store CallWindowProc function address in the thunk data
            z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA", bUnicode)           'Store the SetWindowLong function address in the thunk data
            RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
            nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
        End If
        If nAddr = 0 Then                                                           'Ensure the new WndProc was set correctly
            zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
            GoTo ReleaseMemory
        End If
        'Store the original WndProc address in the thunk data
        RtlMoveMemory z_ScMem + IDX_WNDPROC * 4, VarPtr(nAddr), 4&              ' z_Sc(IDX_WNDPROC) = nAddr
        ssc_Subclass = True                                                     'Indicate success
    Else
        zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
    End If

    Exit Function                                                             'Exit ssc_Subclass
   
CatchDoubleSub:
    zError SUB_NAME, "Window handle is already subclassed"
     
ReleaseMemory:
    VirtualFree z_ScMem, 0, MEM_RELEASE                                       'ssc_Subclass has failed after memory allocation, so release the memory
End Function

'Terminate all subclassing
Private Sub ssc_Terminate()
    ' can be made public. Releases all subclassing
    ' can be removed and zTerminateThunks can be called directly
    zTerminateThunks SubclassThunk
End Sub

'Add the message value to the window handle's specified callback table
Private Sub ssc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    ' Note: can be removed if not needed and zAddMsg can be called directly
    If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                 'Ensure that the thunk hasn't already released its memory
        If When And MSG_BEFORE Then                                             'If the message is to be added to the before original WndProc table...
            zAddMsg uMsg, IDX_BTABLE                                              'Add the message to the before table
        End If
        If When And MSG_AFTER Then                                              'If message is to be added to the after original WndProc table...
            zAddMsg uMsg, IDX_ATABLE                                              'Add the message to the after table
        End If
    End If
End Sub

'Delete the message value from the window handle's specified callback table
Private Sub ssc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    ' Note: can be removed if not needed and zDelMsg can be called directly
    If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then                'Ensure that the thunk hasn't already released its memory
        If When And MSG_BEFORE Then                                             'If the message is to be deleted from the before original WndProc table...
            zDelMsg uMsg, IDX_BTABLE                                              'Delete the message from the before table
        End If
        If When And MSG_AFTER Then                                              'If the message is to be deleted from the after original WndProc table...
            zDelMsg uMsg, IDX_ATABLE                                              'Delete the message from the after table
        End If
    End If
End Sub

'Call the original WndProc
Private Function ssc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' Note: can be removed if you do not use this function inside of your window procedure
    If IsBadCodePtr(zMap_VFunction(lng_hWnd, SubclassThunk)) = 0 Then            'Ensure that the thunk hasn't already released its memory
        If zData(IDX_UNICODE) Then
            ssc_CallOrigWndProc = CallWindowProcW(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
        Else
            ssc_CallOrigWndProc = CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
        End If
    End If
End Function

'Get the subclasser lParamUser callback parameter
Private Function zGet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType) As Long
    'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
    If vType <> CallbackThunk Then
        If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then        'Ensure that the thunk hasn't already released its memory
            zGet_lParamUser = zData(IDX_PARM_USER)                                'Get the lParamUser callback parameter
        End If
    End If
End Function

'Let the subclasser lParamUser callback parameter
Private Sub zSet_lParamUser(ByVal hWnd_Hook_ID As Long, vType As eThunkType, newValue As Long)
    'Note: can be removed if you never need to retrieve/update your user-defined paramter. See ssc_Subclass
    If vType <> CallbackThunk Then
        If IsBadCodePtr(zMap_VFunction(hWnd_Hook_ID, vType)) = 0 Then          'Ensure that the thunk hasn't already released its memory
            zData(IDX_PARM_USER) = newValue                                         'Set the lParamUser callback parameter
        End If
    End If
End Sub

'Add the message to the specified table of the window handle
Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
    Dim nCount As Long                                                        'Table entry count
    Dim nBase  As Long                                                        'Remember z_ScMem
    Dim i      As Long                                                        'Loop index
   
    nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
    z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
   
    If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
        nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
    Else
        nCount = zData(0)                                                       'Get the current table entry count
        If nCount >= MSG_ENTRIES Then                                           'Check for message table overflow
            zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
            GoTo Bail
        End If
   
        For i = 1 To nCount                                                     'Loop through the table entries
            If zData(i) = 0 Then                                                  'If the element is free...
                zData(i) = uMsg                                                     'Use this element
                GoTo Bail                                                           'Bail
            ElseIf zData(i) = uMsg Then                                           'If the message is already in the table...
                GoTo Bail                                                           'Bail
            End If
        Next i                                                                  'Next message table entry
   
        nCount = i                                                              'On drop through: i = nCount + 1, the new table entry count
        zData(nCount) = uMsg                                                    'Store the message in the appended table entry
    End If
   
    zData(0) = nCount                                                         'Store the new table entry count
Bail:
    z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
    Dim nCount As Long                                                        'Table entry count
    Dim nBase  As Long                                                        'Remember z_ScMem
    Dim i      As Long                                                        'Loop index
   
    nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
    z_ScMem = zData(nTable)                                                   'Map zData() to the specified table
   
    If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being deleted from the table...
        zData(0) = 0                                                            'Zero the table entry count
    Else
        nCount = zData(0)                                                       'Get the table entry count
       
        For i = 1 To nCount                                                     'Loop through the table entries
            If zData(i) = uMsg Then                                               'If the message is found...
                zData(i) = 0                                                        'Null the msg value -- also frees the element for re-use
                GoTo Bail                                                           'Bail
            End If
        Next i                                                                  'Next message table entry
       
        zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
    End If
     
Bail:
    z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub


[aaronduran2]

Continúa del post anterior...

Código (vb) [Seleccionar] Expandir


'Map zData() to the thunk address for the specified window handle
Private Function zMap_VFunction(ByVal vFuncTarget As Long, vType As eThunkType) As Long
   
    ' vFuncTarget is one of the following, depending on vType
    '   - Subclassing:  the hWnd of the window subclassed
    '   - Hooking:      the hook type created
    '   - Callbacks:    the ordinal of the callback
   
    Dim thunkCol As Collection
   
    If vType = CallbackThunk Then
        Set thunkCol = z_cbFunk
    ElseIf vType = HookThunk Then
        Set thunkCol = z_hkFunk
    ElseIf vType = SubclassThunk Then
        Set thunkCol = z_scFunk
    Else
        zError "zMap_Vfunction", "Invalid thunk type passed"
        Exit Function
    End If
   
    If thunkCol Is Nothing Then
        zError "zMap_VFunction", "Thunk hasn't been initialized"
    Else
        On Error GoTo Catch
        z_ScMem = thunkCol("h" & vFuncTarget)                    'Get the thunk address
        zMap_VFunction = z_ScMem
    End If
    Exit Function                                               'Exit returning the thunk address
   
Catch:
    zError "zMap_VFunction", "Thunk type for ID of " & vFuncTarget & " does not exist"
End Function

'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
    ' \\LaVolpe -  Note. These two lines can be rem'd out if you so desire. But don't remove the routine
    App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
    MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine
End Sub

'Return the address of the specified DLL/procedure
Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String, ByVal asUnicode As Boolean) As Long
    If asUnicode Then
        zFnAddr = GetProcAddress(GetModuleHandleW(StrPtr(sDLL)), sProc)         'Get the specified procedure address
    Else
        zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc)                 'Get the specified procedure address
    End If
    Debug.Assert zFnAddr                                                      'In the IDE, validate that the procedure address was located
    ' ^^ FYI VB5 users. Search for zFnAddr("vba6", "EbMode") and replace with zFnAddr("vba5", "EbMode")
End Function

'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
    ' Note: used both in subclassing and hooking routines
    Dim bSub  As Byte                                                         'Value we expect to find pointed at by a vTable method entry
    Dim bVal  As Byte
    Dim nAddr As Long                                                         'Address of the vTable
    Dim i     As Long                                                         'Loop index
    Dim j     As Long                                                         'Loop limit
 
    RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                         'Get the address of the callback object's instance
    If Not zProbe(nAddr + &H1C, i, bSub) Then                                 'Probe for a Class method
        If Not zProbe(nAddr + &H6F8, i, bSub) Then                              'Probe for a Form method
            ' \\LaVolpe - Added propertypage offset
            If Not zProbe(nAddr + &H710, i, bSub) Then                            'Probe for a PropertyPage method
                If Not zProbe(nAddr + &H7A4, i, bSub) Then                          'Probe for a UserControl method
                    Exit Function                                                   'Bail...
                End If
            End If
        End If
    End If
 
    i = i + 4                                                                 'Bump to the next entry
    j = i + 1024                                                              'Set a reasonable limit, scan 256 vTable entries
    Do While i < j
        RtlMoveMemory VarPtr(nAddr), i, 4                                       'Get the address stored in this vTable entry
   
        If IsBadCodePtr(nAddr) Then                                             'Is the entry an invalid code address?
            RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
            Exit Do                                                               'Bad method signature, quit loop
        End If

        RtlMoveMemory VarPtr(bVal), nAddr, 1                                    'Get the byte pointed to by the vTable entry
        If bVal <> bSub Then                                                    'If the byte doesn't match the expected value...
            RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
            Exit Do                                                               'Bad method signature, quit loop
        End If
   
        i = i + 4                                                               'Next vTable entry
    Loop
End Function

'Probe at the specified start address for a method signature
Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
    Dim bVal    As Byte
    Dim nAddr   As Long
    Dim nLimit  As Long
    Dim nEntry  As Long
 
    nAddr = nStart                                                            'Start address
    nLimit = nAddr + 32                                                       'Probe eight entries
    Do While nAddr < nLimit                                                   'While we've not reached our probe depth
        RtlMoveMemory VarPtr(nEntry), nAddr, 4                                  'Get the vTable entry
   
        If nEntry <> 0 Then                                                     'If not an implemented interface
            RtlMoveMemory VarPtr(bVal), nEntry, 1                                 'Get the value pointed at by the vTable entry
            If bVal = &H33 Or bVal = &HE9 Then                                    'Check for a native or pcode method signature
                nMethod = nAddr                                                     'Store the vTable entry
                bSub = bVal                                                         'Store the found method signature
                zProbe = True                                                       'Indicate success
                Exit Do                                                             'Return
            End If
        End If
   
        nAddr = nAddr + 4                                                       'Next vTable entry
    Loop
End Function

Private Function zInIDE() As Long
    ' This is only run in IDE; it is never run when compiled
    z_IDEflag = 1
    zInIDE = z_IDEflag
End Function

Private Property Get zData(ByVal nIndex As Long) As Long
    ' retrieves stored value from virtual function's memory location
    RtlMoveMemory VarPtr(zData), z_ScMem + (nIndex * 4), 4
End Property

Private Property Let zData(ByVal nIndex As Long, ByVal nValue As Long)
    ' sets value in virtual function's memory location
    RtlMoveMemory z_ScMem + (nIndex * 4), VarPtr(nValue), 4
End Property

Private Sub zUnThunk(ByVal thunkID As Long, ByVal vType As eThunkType)
    ' Releases a specific subclass, hook or callback
    ' thunkID depends on vType:
    '   - Subclassing:  the hWnd of the window subclassed
    '   - Hooking:      the hook type created
    '   - Callbacks:    the ordinal of the callback

    Const IDX_SHUTDOWN  As Long = 1
    Const MEM_RELEASE As Long = &H8000&                                'Release allocated memory flag
   
    If zMap_VFunction(thunkID, vType) Then
        Select Case vType
            Case SubclassThunk
                If IsBadCodePtr(z_ScMem) = 0 Then       'Ensure that the thunk hasn't already released its memory
                    zData(IDX_SHUTDOWN) = 1             'Set the shutdown indicator
                    zDelMsg ALL_MESSAGES, IDX_BTABLE    'Delete all before messages
                    zDelMsg ALL_MESSAGES, IDX_ATABLE    'Delete all after messages
                    '\\LaVolpe - Force thunks to replace original window procedure handle. Without this, app can crash when a window is subclassed multiple times simultaneously
                    If zData(IDX_UNICODE) Then          'Force window procedure handle to be replaced
                        SendMessageW thunkID, 0&, 0&, ByVal 0&
                    Else
                        SendMessageA thunkID, 0&, 0&, ByVal 0&
                    End If
                End If
                z_scFunk.Remove "h" & thunkID           'Remove the specified thunk from the collection
            Case HookThunk
                If IsBadCodePtr(z_ScMem) = 0 Then       'Ensure that the thunk hasn't already released its memory
                    zData(IDX_SHUTDOWN) = 1             'Set the shutdown indicator
                    zData(IDX_ATABLE) = 0               ' want no more After messages
                    zData(IDX_BTABLE) = 0               ' want no more Before messages
                End If
                z_hkFunk.Remove "h" & thunkID           'Remove the specified thunk from the collection
            Case CallbackThunk
                If IsBadCodePtr(z_ScMem) = 0 Then       'Ensure that the thunk hasn't already released its memory
                    VirtualFree z_ScMem, 0, MEM_RELEASE 'Release allocated memory
                End If
                z_cbFunk.Remove "h" & thunkID           'Remove the specified thunk from the collection
        End Select
    End If

End Sub

Private Sub zTerminateThunks(ByVal vType As eThunkType)
    ' Removes all thunks of a specific type: subclassing, hooking or callbacks
    Dim i As Long
    Dim thunkCol As Collection
   
    Select Case vType
        Case SubclassThunk
            Set thunkCol = z_scFunk
        Case HookThunk
            Set thunkCol = z_hkFunk
        Case CallbackThunk
            Set thunkCol = z_cbFunk
        Case Else
            Exit Sub
    End Select
   
    If Not (thunkCol Is Nothing) Then                 'Ensure that hooking has been started
        With thunkCol
            For i = .Count To 1 Step -1                   'Loop through the collection of hook types in reverse order
                z_ScMem = .Item(i)                          'Get the thunk address
                If IsBadCodePtr(z_ScMem) = 0 Then           'Ensure that the thunk hasn't already released its memory
                    Select Case vType
                        Case SubclassThunk
                            zUnThunk zData(IDX_INDEX), SubclassThunk     'Unsubclass
                        Case HookThunk
                            zUnThunk zData(IDX_INDEX), HookThunk             'Unhook
                        Case CallbackThunk
                            zUnThunk zData(IDX_CALLBACKORDINAL), CallbackThunk ' release callback
                    End Select
                End If
            Next i                                        'Next member of the collection
        End With
        Set thunkCol = Nothing                         'Destroy the hook/thunk-address collection
    End If
End Sub

Private Function GetDriveBusType(ByVal sDrive As String) As STORAGE_BUS_TYPE
    Dim lret                        As Long
    Dim lDevice                     As Long
    Dim tSTORAGE_DEVICE_DESCRIPTOR  As STORAGE_DEVICE_DESCRIPTOR
    Dim tOVERLAPPED                 As OVERLAPPED
    Dim tSTORAGE_PROPERTY_QUERY     As STORAGE_PROPERTY_QUERY

    sDrive = Left(sDrive, 1) & ":"
   
    lDevice = CreateFile("\\.\" & sDrive, GENERIC_READ, _
       FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
   
    If Not lDevice = INVALID_HANDLE_VALUE Then
        With tSTORAGE_PROPERTY_QUERY
            .PropertyId = StorageDeviceProperty
            .QueryType = PropertyStandardQuery
        End With
   
        Call DeviceIoControl(lDevice, _
           IOCTL_STORAGE_QUERY_PROPERTY, _
           tSTORAGE_PROPERTY_QUERY, _
           LenB(tSTORAGE_PROPERTY_QUERY), _
           tSTORAGE_DEVICE_DESCRIPTOR, _
           LenB(tSTORAGE_DEVICE_DESCRIPTOR), _
           lret, tOVERLAPPED)
       
        GetDriveBusType = tSTORAGE_DEVICE_DESCRIPTOR.BusType
        Call CloseHandle(lDevice)
    End If
   
End Function

Private Function IOCTL_STORAGE_QUERY_PROPERTY() As Long
    IOCTL_STORAGE_QUERY_PROPERTY = _
       (IOCTL_STORAGE_BASE * 2 ^ 16) Or _
       (FILE_ANY_ACCESS * 2 ^ 14) Or _
       (&H500 * 2 ^ 2) Or _
       (METHOD_BUFFERED)
End Function

Private Function UnitFromMask(ByVal lMask As Long) As String
    Dim i As Long
    For i = 0 To 25
        If (lMask And 2 ^ i) Then
            UnitFromMask = Chr$(i + Asc("A"))
            Exit Function
        End If
    Next
End Function

'- ordinal #1
Private Sub WndProc( _
       ByVal bBefore As Boolean, _
       ByRef bHandled As Boolean, _
       ByRef lReturn As Long, _
       ByVal lng_hWnd As Long, _
       ByVal uMsg As Long, _
       ByVal wParam As Long, _
       ByVal lParam As Long, _
       ByRef lParamUser As Long)
   
    Dim tDEV_BROADCAST_HDR      As DEV_BROADCAST_HDR
    Dim tDEV_BROADCAST_VOLUME   As DEV_BROADCAST_VOLUME
    Dim sDrive                  As String
   
    Select Case wParam
   
        Case DBT_DEVICEARRIVAL, DBT_DEVICEREMOVECOMPLETE
       
            Call CopyMemory(tDEV_BROADCAST_HDR, _
               ByVal lParam, LenB(tDEV_BROADCAST_HDR))
           
            If tDEV_BROADCAST_HDR.dbch_devicetype = DBT_DEVTYP_VOLUME Then
               
                Call CopyMemory(tDEV_BROADCAST_VOLUME, _
                   ByVal lParam, LenB(tDEV_BROADCAST_VOLUME))
               
                sDrive = UnitFromMask(tDEV_BROADCAST_VOLUME.dbcv_unitmask)
               
                If Not sDrive = vbNullString Then
                    If wParam = DBT_DEVICEARRIVAL Then
                        If GetDriveBusType(sDrive) = BusTypeUsb Then
                            RaiseEvent DriveArrival(sDrive, GetDriveType(sDrive & ":\"))
                        End If
                    Else
                        RaiseEvent DriveRemoval(sDrive)
                    End If
                End If
               
            End If
       
    End Select
   
End Sub

' *************************************************************
' C A U T I O N   C A U T I O N   C A U T I O N   C A U T I O N
' -------------------------------------------------------------
' DO NOT ADD ANY OTHER CODE BELOW THE "END SUB" STATEMENT BELOW
'   add this warning banner to the last routine in your class
' *************************************************************


La forma de usarla es la siguiente:

- En un form, declaras la clase.
- En el evento DriveArrival de la clase, colocas el siguiente código:

Código (vb) [Seleccionar] Expandir


MsgBox "Detectada ", sDrive, lDriveType

- En el evento DriveRemoval:

Código (vb) [Seleccionar] Expandir


MsgBox "Extraída ", sDrive


Saludos, y perdón por el post tan largo.

[Mad Antrax]

Saludos, y perdón por el post tan largo.

Perdonado, pero usa las etiquetas de código GeSHI, ejemplo

Código [Seleccionar] Expandir


[code][/ code] No se utiliza


Código [Seleccionar] Expandir


[code=vb][/ code] Sí se utiliza


Así queda en formato VB6 y mola más

Saludos!![/code][/code]

[aaronduran2]

Gracias, ||MadAntrax||. Lo haré la próxima vez.

[josp24]

Muchas gracias por tu aporte aaronduran2. Ya tome el código que me pasaste e hice lo que me dijiste al pie de la letra, pero fijate que cuando corro el programa e inserto o extraigo la memoria USB, no pasa nada, no me salta ningún mensaje.

Qué puede estar sucediendo? Espero tu respuesta, gracias.

[josp24]

ok, no me daba ningun mensaje porque me faltaba la siguiente línea:

Private Sub Form_Load()
    Set USB = New clsUSB
End Sub

Pero ahora cuando introduzco la memoria o la extraigo me da el siguiente error:

Error 13 en tiempo de ejecución: No coinciden los tipos.

Este error me da en las siguientes líneas:

Private Sub USB_DriveArrival(ByVal sDrive As String, ByVal lDriveType As eDriveType)
    MsgBox "Detectada", sDrive, lDriveType
End Sub

Private Sub USB_DriveRemoval(ByVal sDrive As String)
    MsgBox "Extraída", sDrive
End Sub

[cobein]

Podes descargar un ejemplo funcional de aca

USB detection.zip on UpSourceCode.com.ar


Edit reemplaza las comas por &

[josp24]

Perfecto COBEIN ya me funciona bien !!!

Solo que en los mensajes se colocan unos caracteres al final:

DetectadaF2

ExtraidaF

Ahora cómo puedo hacer para que no se pueda usar la memoria usb hasta que el usuario se idéntifique o en su defecto rechazarla?

[krackwar]

Perfecto COBEIN ya me funciona bien !!!

Solo que en los mensajes se colocan unos caracteres al final:

DetectadaF2

ExtraidaF

Ahora cómo puedo hacer para que no se pueda usar la memoria usb hasta que el usuario se idéntifique o en su defecto rechazarla?

Quieres que te lo agamos todo  .Google no muerde