Detecter insertion cd et bloquer autorun

Soyez le premier à donner votre avis sur cette source.

Vue 7 829 fois - Téléchargée 555 fois

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...

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

cs_Cpapy
Messages postés
133
Date d'inscription
mercredi 30 octobre 2002
Statut
Membre
Dernière intervention
25 septembre 2007

Bonjour,

Je me suis totalement trompé, la procédure fonctionne correctement et me sera très utile.

J'ai eu de grosses difficultés à trouver la raison qui faisais boucler mon programme. ci-dessous le code qui me posais problème:
'-----------------------------------------------------------
Label1 = "Insertion CD lecteur " & Retour.DriveLetter & ":"
File1.Path = ":" & Retour.DriveLetter & \Sauvegarde"
'-----------------------------------------------------------

Le fait de placer ":" devant la lettre du driver entraînait un débranchement dans la procédure
HookFunc --> If (Err.Number) Then .......... puis tout était bloqué. (Obligé de sortir par Ctrl+ Alter + Suppr)

Bref ça marche. Merci pour ton aide et surtout pour ta procédure.
nicolas9487
Messages postés
2
Date d'inscription
jeudi 10 avril 2003
Statut
Membre
Dernière intervention
22 janvier 2007

Case tClose
Label1 = "Insertion CD lecteur " & Retour.DriveLetter & ":"
instruction 2
instruction 3
...
Case ...

ou alors, je n'ai pas compris le sens de ta question
cs_Cpapy
Messages postés
133
Date d'inscription
mercredi 30 octobre 2002
Statut
Membre
Dernière intervention
25 septembre 2007

Bonjour,

Je souhaiterais utiliser ce programme mais impossible de mettre rajouter des instructions après:
---> Case tClose: Label1 = "Insertion CD lecteur " & Retour.DriveLetter & ":"

Je souhaiterais que mon programme reprenne la main immédiatement après l'instruction ci-dessus

Si je rajoute des instructions ça Boucle !

As-tu la solution à ce problème

Par avance Merci.
cs_JLN
Messages postés
373
Date d'inscription
samedi 1 juin 2002
Statut
Membre
Dernière intervention
17 juin 2013

- La clé de registre modifie en dur l'autorun et pour être pris en compte on doit redémarrer, la richesse de ce prog est justement l'effet temporaire seulement si necessaire.
- Pour Windev, Me n'existe pas, mais Me représente l'objet fenetre alors tu remplaces par le nom de la tienne et ca peut le faire.

- Ce code est super, mais ce qu'il lui manque, c'est le blocage, même quand la fenetre de premier plan n'est pas la sienne. Il faudrait tenter avec une variable public qui contiendrai le hwnd de la fenetre de premier plan... à essayer.

Bonne Prog à tous,

JLN
zyx production
Messages postés
1
Date d'inscription
mardi 21 décembre 2004
Statut
Membre
Dernière intervention
23 décembre 2004

J'ai VB .NET, mais je n'arrive pas a le faire marcher. Est-ce que quelqu'un serait capable de m'aider.

En faite, je voudrait le faire marche sous du windev, a part que le problème est que la propriété "ME" n'existe pas. Car sinon, j'ai trouvé le reste.

La solution qui me reste est de faire un composante en .NET que j'importerait.

HELP !!!

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.