Bloquear bandeja de CD

[ebb]

quien me dice como puedo por vb6 bloquear cualquier unidad de cd-rom é las demas unidades del pc



gracias

[ranefi]

Hola ebb, buena tarde. Aquí te dejo el código de un programa que sirve para grabar CD's, en éste, viene el código que buscas.


Para ver este enlace Registrate o Inicia Sesion

Código

Espero y te sirva. Nos vemos.


PD: Procura cambiar el título de tu mensaje, mmm, estaría bien que lo cambiaras por "Bloquear unidad de CD"

[ranefi]

Hola ebb. Espero que hayas encontrado lo que necesitabas con el código que te proporcioné, si no es así, aquí te dejo el código que necesitas:

Agregar 1 control ListBox, 2 CommandButton (un arreglo de controles; 0 y 1) e REPLACEar el siguiente código

En el formulario

Código:

Option Explicit




Private Sub Form_Load()
           LoadAvailableDrives List1
           Command1(0).Enabled = False
           Command1(1).Enabled = False
End Sub


Private Sub List1_Click()
           Command1(0).Enabled = List1.ListIndex > -1
           Command1(1).Enabled = List1.ListIndex > -1
End Sub


Private Sub Command1_Click(Index As Integer)
           Dim fLock As Boolean
           Dim result As Boolean
           Dim sDrive As String
           

           If List1.ListIndex > -1 Then
                  sDrive = List1.List(List1.ListIndex)

                  fLock = CBool(Index)
                  result = DeviceLock(sDrive, fLock)

                  If result Then
                             Select Case Index
                                    Case 0
                                               Label1.Caption = "El dispositivo " & _
                                                sDrive & " está desbloqueado."
                                    Case 1
                                               Label1.Caption = "El dispositivo " & _
                                                sDrive & " está bloqueado."
                             End Select
                  Else
                             Label1.Caption = _
                                    "Fallo en llamada - " & _
                                                "Quizá no existe el dispositivo."
                  End If
           End If
End Sub


Private Sub LoadAvailableDrives(lst As ListBox)
           Dim lpBuffer As String
           Dim drvType As Long
           Dim currDrive As String


           lpBuffer = GetDriveString()

           Do Until lpBuffer = Chr(0)
                  currDrive = StripNulls(lpBuffer)
                  drvType = GetDriveType(currDrive)
           
                  If (drvType = DRIVE_CDROM) Or _
                             (drvType = DRIVE_REMOVABLE) Then
                             lst.AddItem currDrive
                  End If
           Loop
End Sub


Private Function StripNulls(startstr As String) As String
      Dim pos As Long

      pos = InStr(startstr, Chr$(0))
     
      If pos Then
                  StripNulls = Mid$(startstr, 1, pos - 1)
                  startstr = Mid$(startstr, pos + 1, Len(startstr))
      End If
End Function


Private Function GetDriveString() As String
           Dim sBuffer As String

           sBuffer = Space$((26 * 4) + 1)
     
      If GetLogicalDriveStrings(Len(sBuffer), sBuffer) Then
                  GetDriveString = Trim$(sBuffer)
           End If
End Function

En el módulo

Código:

Option Explicit

Public Const DRIVE_REMOVABLE As Long = 2
Public Const DRIVE_CDROM As Long = 5
Public Const INVALID_HANDLE_VALUE As Long = -1&
Public Const GENERIC_READ As Long = &H80000000
Public Const FILE_SHARE_READ As Long = &H1
Public Const FILE_SHARE_WRITE As Long = &H2
Public Const FILE_ANY_ACCESS As Long = &H0
Public Const FILE_READ_ACCESS  As Long = &H1
Public Const FILE_WRITE_ACCESS As Long = &H2
Public Const OPEN_EXISTING As Long = 3
Public Const IOCTL_STORAGE_MEDIA_REMOVAL As _
    Long = &H2D4804

Public Type PREVENT_MEDIA_REMOVAL
   PreventMediaRemoval As Byte
End Type

Public Declare Function GetLogicalDriveStrings _
    Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
 
Public Declare Function GetDriveType Lib "kernel32" _
   Alias "GetDriveTypeA" _
  (ByVal lpRootPathName As String) As Long
 
Public 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 Any) As Long

Public 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

Public Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long

Public Function DeviceLock(sDrive As String, fLock As Boolean) As Boolean
   Dim hDevice As Long
   Dim PMR As PREVENT_MEDIA_REMOVAL
   Dim bytesReturned As Long
   Dim success As Long
 
   sDrive = UnQualifyPath(sDrive)

   hDevice = CreateFile("\\.\" & sDrive, _
                        GENERIC_READ, _
                        FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                        ByVal 0&, _
                        OPEN_EXISTING, _
                        0&, 0&)

   
   If hDevice <> INVALID_HANDLE_VALUE Then
      PMR.PreventMediaRemoval = CByte(Abs(fLock))

      success = DeviceIoControl(hDevice, _
                                IOCTL_STORAGE_MEDIA_REMOVAL, _
                                PMR, _
                                Len(PMR), _
                                ByVal 0&, _
                                0&, _
                                bytesReturned, _
                                ByVal 0&)
   
   End If
                       
   Call CloseHandle(hDevice)
   DeviceLock = success <> 0
End Function


Private Function UnQualifyPath(ByVal sPath As String) As String
   sPath = Trim$(sPath)
   
   If Right$(sPath, 1) = "\" Then
      UnQualifyPath = Left$(sPath, Len(sPath) - 1)
   Else
      UnQualifyPath = sPath
   End If
End Function

Espero que te sea de utilidad.

PD: Voy a cambiar el título de tu mensaje.

[ebb]

ey gracias por el codigo

pero tengo un pequeñito problemilla
cuando lo ejecuto me sale un mensaje y me lleba

"Private Sub Command1_Click(Index As Integer)"

la declaracion del procedimiento no coincide con la descripcion del evento


quien me pueda ayudar

[ranefi]

Agregar 1 control ListBox, 2 CommandButton (un arreglo de controles; 0 y 1) e REPLACEar el siguiente código

Buen día ebb. Recuerda, debes crear un arreglo de controles con los CommandButton, esto se crea así:


1.- Agrega 1 CommandButton

2.- Copia ése mismo CommandButton

3.- Presiona CTRL + V

4.- Responde con un Sí al mensaje que te aparece.

Eso es todo.


Espero que tu duda haya quedado solventada. Nos vemos