Detecter insertion cd et bloquer autorun

Télécharger le projet
Commenter

Description

Permet de détecter l'insertion et l'ejection d'un CD, en renvoyant la lettre du lecteur concerné, et permet aussi de désactiver temporairement l'autorun, ou de le réactiver.
Ce petit bout de code fait des miracles ! après des heures de recherches, j'ai réussi à rassembler ces fonctions. Ne me demandez pas comment ca marche, j'ai pas encore eu le temps de tout comprendre, mais CA MARCHE !
J'ai remarqué que plusieurs personnes étaient en quête de ce genre de fonctions, sans réponses, et je ne crois pas que ce genre de sources existe déjà sur le site.

Source / Exemple : 


'*********************************
'Code à mettre dans un module
'*********************************

Option Explicit

Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long

Public Const RegMsg As String = "QueryCancelAutoPlay"

Public Const WM_DEVICECHANGE = &H219&

Public m_RegMsg As Long

Public Enum OperationType
    tOpen
    tClose
End Enum

Public Type OperationResult
    Operation As OperationType
    DriveLetter As String
End Type

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (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 SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const keyObjPtr As String = "ObjectPointer"
Private Const keyWndProc As String = "OldWindowProc"

Private Const GWL_WNDPROC As Long = -4&
Private Const DBT_DEVICEARRIVAL = &H8000&
Private Const DBT_DEVICEREMOVECOMPLETE = &H8004&
Private Const DBTF_MEDIA = &H1&
Private Const DBT_DEVTYP_VOLUME = &H2&

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

Private Type DEV_BROADCAST_VOLUME
    dbch_size As Long
    dbch_devicetype As Long
    dbch_reserved As Long
    dbcv_unitmask As Long
    dbcv_flags As Integer
End Type

Private Function HookFunc(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
    Dim lpObjPtr As Long
    Const WM_DESTROY = &H2
    Dim obj As Form1
   
    lpObjPtr = GetProp(hWnd, keyObjPtr)
    If (lpObjPtr <> 0) Then
        CopyMemory obj, lpObjPtr, 4
        
        On Error Resume Next
        
        HookFunc = obj.WindowProc(hWnd, msg, wp, lp)
        
        If (Err.Number) Then UnhookWindow hWnd
        
        CopyMemory obj, Nothing, 4
        
        If msg = WM_DESTROY Then Call UnhookWindow(hWnd)
    End If
End Function

Public Sub HookWindow(hWnd As Long, thing As Object)
    If GetProp(hWnd, keyWndProc) Then Exit Sub
    Call SetProp(hWnd, keyObjPtr, ObjPtr(thing))
    Call SetProp(hWnd, keyWndProc, GetWindowLong(hWnd, GWL_WNDPROC))
    Call SetWindowLong(hWnd, GWL_WNDPROC, AddressOf HookFunc)
End Sub

Public Sub UnhookWindow(hWnd As Long)
    Dim lpWndProc As Long
    
    lpWndProc = GetProp(hWnd, keyWndProc)
    
    If (lpWndProc <> 0) Then Call SetWindowLong(hWnd, GWL_WNDPROC, lpWndProc)
    
    Call RemoveProp(hWnd, keyObjPtr)
    Call RemoveProp(hWnd, keyWndProc)
End Sub

Public Function InvokeWindowProc(hWnd As Long, msg As Long, wp As Long, lp As Long) As Long
    InvokeWindowProc = CallWindowProc(GetProp(hWnd, "OldWindowProc"), hWnd, msg, wp, lp)
End Function

Public Function ProcessDeviceChange(wParam As Long, lParam As Long) As OperationResult
    Dim DBHdr As DEV_BROADCAST_HDR
    Dim DBVol As DEV_BROADCAST_VOLUME
    
    CopyMemory DBHdr, ByVal lParam, LenB(DBHdr)
    Select Case wParam
        Case DBT_DEVICEARRIVAL
            If DBHdr.dbch_devicetype = DBT_DEVTYP_VOLUME Then
                CopyMemory DBVol, ByVal lParam, LenB(DBVol)
                If (DBVol.dbcv_flags And DBTF_MEDIA) = DBTF_MEDIA Then
                    ProcessDeviceChange.Operation = tClose
                    ProcessDeviceChange.DriveLetter = Chr$(FirstDriveFromMask(DBVol.dbcv_unitmask))
                End If
            End If
        Case DBT_DEVICEREMOVECOMPLETE
            If DBHdr.dbch_devicetype = DBT_DEVTYP_VOLUME Then
                CopyMemory DBVol, ByVal lParam, LenB(DBVol)
                If (DBVol.dbcv_flags And DBTF_MEDIA) = DBTF_MEDIA Then
                    ProcessDeviceChange.Operation = tOpen
                    ProcessDeviceChange.DriveLetter = Chr$(FirstDriveFromMask(DBVol.dbcv_unitmask))
                End If
            End If
    End Select
End Function

Private Function FirstDriveFromMask(ByVal unitmask As Long) As Byte
    Dim b As Byte
    For b = 0 To 25
        If (unitmask And 2 ^ b) Then
            FirstDriveFromMask = Asc("A") + b
            Exit For
        End If
    Next b
End Function

'*********************************
'Code à mettre dans une feuille
'Ajouter deux labels : label1 et label2
'*********************************

Option Explicit

Private Sub Form_Load()
   m_RegMsg = RegisterWindowMessage(RegMsg)
   Call HookWindow(Me.hWnd, Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Call UnhookWindow(Me.hWnd)
End Sub

Friend Function WindowProc(hWnd As Long, msg As Long, wp As Long, lp As Long) As Long
    Dim Result As Long
    Dim Retour As OperationResult
    
    Select Case msg
        Case m_RegMsg
            Result = 1
            Label2 = "Autorun détecté et bloqué"
        Case WM_DEVICECHANGE
            Result = 0
            Retour = ProcessDeviceChange(wp, lp)
            Select Case Retour.Operation
                Case tClose: Label1 = "Insertion CD lecteur " & Retour.DriveLetter & ":"
                Case tOpen: Label1 = "Ejection CD lecteur " & Retour.DriveLetter & ":"
            End Select
        Case Else
        Result = InvokeWindowProc(hWnd, msg, wp, lp)
    End Select
   WindowProc = Result
End Function

Conclusion :


Dernier détail de taille : le code n'est pas de moi, j'ai simplement mis bout à bout des trucs trouvés ca et là sur le net, et je les aient remaniés à ma sauce.
Les lauriers ne sont donc pas pour moi...
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.