HackRoom Progetto source : raccolta di sorgenti

Source manager

Elenco funzioni :
Clear_Scree
Client_WP
CounterInPh
doubleNB
ShelldiWindow
MontaDischiLinu
CriptaHTM
ClearScreenPytho
ï»¿FunzionePin
OpenAndClos
N.A.K
Bluetooth Finde
calcolatrice!

Lascia il tuo sorgente

Autore : enemy[at]hackroom[dot]org
'Questo è un esempio in Visual Basic 6 come aprire e chiudere lo sportellino CD/DVD

-----------------------------------------------------------
Form1.frm
--------------------- Start Code -----------------------
Option Explicit

Private Sub Form_Load()
Dim fs, d, dc
Set fs = CreateObject("Scripting.FileSystemObject")
Set dc = fs.Drives
For Each d In dc
If d.DriveType = 4 Then 'Verifico se il Drive è Lettore CD/DVD include anche dischi virtuali
DriveList.AddItem d.DriveLetter & ":"
End If
Next
DriveList.ListIndex = 0 'Visualizzo il primo disponibile
End Sub

Private Sub cmbOpen_Click()
If Not SetDoor(DriveList.Text, True) Then
MsgBox "Impossibile aprire cd unità " & DriveList.Text, vbCritical
End If
End Sub

Private Sub cmbClose_Click()
If Not SetDoor(DriveList.Text, False) Then
MsgBox "Impossibile chiudere cd unità " & DriveList.Text, vbCritical
End If
End Sub
--------------------- End Code -------------------------

-----------------------------------------------------------
CD.bas
--------------------- Start Code -----------------------
Private Const MMSYSERR_NOERROR = 0
Private Const MCI_CLOSE = &H804
Private Const MCI_OPEN = &H803
Private Const MCI_OPEN_ELEMENT = &H200&
Private Const MCI_OPEN_SHAREABLE = &H100&
Private Const MCI_OPEN_TYPE = &H2000&
Private Const MCI_SET = &H80D
Private Const MCI_SET_DOOR_OPEN = &H100&
Private Const MCI_SET_DOOR_CLOSED = &H200&
'Tipi-----------------------------------------------
Private Type MCI_OPEN_PARMS
dwCallback As Long
wDeviceID As Long
lpstrDeviceType As String
lpstrElementName As String
lpstrAlias As String
End Type
'DLL------------------------------------------------
Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As Long, ByRef dwParam2 As Any) As Long

Public Function SetDoor(ByVal Drive As String, ByVal bOpen As Boolean) As Boolean
Dim MciOpenParms As MCI_OPEN_PARMS
Dim ret As Long
MciOpenParms.lpstrDeviceType = "cdaudio" 'Tipo
MciOpenParms.lpstrElementName = Drive 'Unità
'apro la comunicazione con il Device
ret = mciSendCommand(0, MCI_OPEN, (MCI_OPEN_TYPE Or MCI_OPEN_ELEMENT Or MCI_OPEN_SHAREABLE), MciOpenParms)
If ret = MMSYSERR_NOERROR Then
If bOpen Then
Call mciSendCommand(MciOpenParms.wDeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0) 'Apri Cassetto
Else
Call mciSendCommand(MciOpenParms.wDeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0) 'Chiudi Cassetto
End If
Call mciSendCommand(MciOpenParms.wDeviceID, MCI_CLOSE, 0, 0) 'chiudo la cominicazione con il Device
SetDoor = True
End If
End Function
--------------------- End Code -------------------------