کمک : باز کردن در سی دی رام از طریق نام درایو !

بچه ها کمک :
فکر کنید چند تا درایو سی دی رام دارید و می خواهید با انتخاب نام درایو یا ...
طوری که وقتی آن درایو را انتخاب می کنید یا نام درایو را می نویسید !
---------------------------------------------------------------------------------------
بتوانید درایو را خارج یا وارد کنید !
مثل کار clone cd و انتحاب eject روی درایو سی دی !

با دستورات MCI مي‌شه
و با دستورات ASPI
توي MSDN يا گوگل جستجو كنيد خيلي راحت پيدا مي‌شه
البته كار كردن با ASPI و VB غير ممكنه بايد ASPIShim رو دانلود كنيد

ابتدا کامپوننت WindowsMediaPlayer رو انتخاب کن و سپس کد زیر رو بنویس :

کد:

---

Option Explicit
Dim lngCount As Long

Private Sub Command1_Click()
On Error Resume Next
WindowsMediaPlayer1.cdromCollection.Item(List1.ListIndex).eject
End Sub

Private Sub Form_Load()
On Error Resume Next
List1.Clear
WindowsMediaPlayer1.Visible = False
For lngCount = 0 To WindowsMediaPlayer1.cdromCollection.Count - 1
List1.AddItem WindowsMediaPlayer1.cdromCollection.Item(lngCount).driveSpecifier
Next
End Sub

---

بابت جوابها تون ممنون بچه ها من می خوام ای دی یاهوی شما را داشته باشم
----
نیاز به کمک دارم کلا !
ای دی منا اد کنید لطفا
زیاد نمی تونم On شم

ببین دوست من !
با mci نمیشه چون نام داریو نمی گیره - شاید من بلد نیستم شرمنده !
دوم اینکه اون مدیا پلیری که می گی مرتبط با خود ویندوزه یعنی روی همه ویندوز ها جواب نمی ده !
یه کنترل دیگه هم هست به نام msdxm.ocx که اون هم این قابلیت را نداره !
-------------------------------
من می خوام روی هر سیستمی بردم جواب بده !

کد:

---

Option Explicit

Private Declare Function GetVolumeInformationA Lib "kernel32" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) 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 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 Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private sDriveNames() As String
Private Const GENERIC_READ = &H80000000
Private Const FILE_FLAG_WRITE_THROUGH = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_NEW = 1
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const TRUNCATE_EXISTING = 5
Private Const IOCTL_STORAGE_EJECT_MEDIA = 2967560
Private Const IOCTL_STORAGE_LOAD_MEDIA = 2967564

Private Sub AssembleDriveLetter()
Dim I As Integer
Call FindCDRom
ReDim sDriveNames(5)
For I = 0 To 5
If ListEject.List(I) <> "" Then sDriveNames(I) = LCase(Left$(ListEject.List(I), 1))
Next
End Sub

Private Sub EjectCmd_Click()
On Error Resume Next
If ListEject.Selected(ListEject.ListIndex) = True Then
Call EjectDrive(LCase(Left$(ListEject.List(ListEject.ListIndex), 1)))
End If
End Sub

Private Function EjectDrive(driveLetter As String) As Boolean
Dim hDisk As Long
Dim dwRc As Long
Dim sDisk As String
sDisk = "\\.\" & UCase(driveLetter) & ":"
hDisk = CreateFile(sDisk, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or _
                    FILE_SHARE_WRITE, ByVal CLng(0), OPEN_EXISTING, FILE_FLAG_WRITE_THROUGH, _
                    ByVal CLng(0))

If hDisk = -1 Then
EjectDrive = False
Exit Function
End If
FlushFileBuffers (hDisk)
If DeviceIoControl(hDisk, IOCTL_STORAGE_EJECT_MEDIA, _
                    ByVal CLng(0), 0, ByVal CLng(0), 0, _
                    dwRc, ByVal CLng(0)) = 0 Then
EjectDrive = False
Else
EjectDrive = True
End If
CloseHandle (hDisk)
End Function

Private Sub FindCDRom()
Dim Drive As Integer
Dim A As Integer
ListEject.Clear
A = 0
For Drive = 65 To 90
Select Case GetDriveType(Chr(Drive) & ":\")
Case 5
If Drive = 0 Then Exit For
ListEject.AddItem Chr(Drive) & ":\ [" & GetVolumeName(Chr(Drive) & ":\") & "]"
If A + 1 = 6 Then Exit For Else A = A + 1
End Select
Next
End Sub

Private Sub Form_Load()
Timer1.Interval = 5000
Call AssembleDriveLetter
End Sub

Private Function GetVolumeName(Drive As String) As String
On Local Error Resume Next
Dim VolName As String, FSys As String, Ret As Long
Dim VolNumber As Long, MCM As Long, FSF As Long
Dim DriveType As Long
Const MaxSize As String = 127
VolName = Space(MaxSize)
FSys = Space(MaxSize)
Ret = GetVolumeInformationA(Drive, VolName, MaxSize, VolNumber, MCM, FSF, FSys, MaxSize)
VolName = Left(VolName, IIf(InStr(VolName, vbNullChar) = 0, 0, InStr(VolName, vbNullChar) - 1))
GetVolumeName = IIf(Ret = 0, "Empty", VolName)
End Function

Private Sub LoadCmd_Click()
On Error Resume Next
If ListEject.Selected(ListEject.ListIndex) = True Then
Call LoadDrive(LCase(Left$(ListEject.List(ListEject.ListIndex), 1)))
End If
End Sub

Public Function LoadDrive(driveLetter As String) As Boolean
Dim hDisk As Long
Dim dwRc As Long
Dim sDisk As String
sDisk = "\\.\" & UCase(driveLetter) & ":"
hDisk = CreateFile(sDisk, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or _
                    FILE_SHARE_WRITE, ByVal CLng(0), OPEN_EXISTING, FILE_FLAG_WRITE_THROUGH, _
                    ByVal CLng(0))
 
If hDisk = -1 Then
LoadDrive = False
Exit Function
End If
FlushFileBuffers (hDisk)
If DeviceIoControl(hDisk, IOCTL_STORAGE_LOAD_MEDIA, _
                    ByVal CLng(0), 0, ByVal CLng(0), 0, _
                    dwRc, ByVal CLng(0)) = 0 Then
LoadDrive = False
Else
LoadDrive = True
End If
CloseHandle (hDisk)
End Function

Private Sub Timer1_Timer()
Call AssembleDriveLetter
End Sub

---

نقل قول:

---

نوشته شده توسط black_storm [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

ببین دوست من !
با mci نمیشه چون نام داریو نمی گیره - شاید من بلد نیستم شرمنده !

---

کد:

---

Option Explicit

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpszCommand As String, ByVal lpszReturnString As String, ByVal cchReturnLength As Long, ByVal hwndCallBack As Long) As Long
Private Declare Function GetVolumeInformationA Lib "kernel32" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private sDriveNames() As String

Private Sub AssembleDriveLetter()
Dim I As Integer
Call FindCDRom
ReDim sDriveNames(5)
For I = 0 To 5
If ListEject.List(I) <> "" Then sDriveNames(I) = LCase(Left$(ListEject.List(I), 1))
Next
End Sub

Private Sub CmdEject_Click()
Dim DriveSet
DriveSet = Left$(ListEject.List(ListEject.ListIndex), 3)
mciSendString "Open " & DriveSet & ": Alias " & "Drive" & DriveSet & " Type CDAudio", 0&, 0&, 0&      'Once set, is applied to system until restart
mciSendString "set Drive" & DriveSet & " door open", 0&, 0&, 0&
End Sub

Private Sub CmdLoad_Click()
Dim DriveSet
DriveSet = Left$(ListEject.List(ListEject.ListIndex), 3)
mciSendString "Open " & DriveSet & ": Alias " & "Drive" & DriveSet & " Type CDAudio", 0&, 0&, 0&      'Once set, is applied to system until restart
mciSendString "set Drive" & DriveSet & " door closed", 0&, 0&, 0&
End Sub

Private Sub FindCDRom()
Dim Drive As Integer
Dim A As Integer
ListEject.Clear
A = 0
For Drive = 65 To 90
Select Case GetDriveType(Chr(Drive) & ":\")
Case 5
If Drive = 0 Then Exit For
ListEject.AddItem Chr(Drive) & ":\ [" & GetVolumeName(Chr(Drive) & ":\") & "]"
If A + 1 = 6 Then Exit For Else A = A + 1
End Select
Next
End Sub

Private Sub Form_Load()
Timer1.Interval = 5000
Call AssembleDriveLetter
End Sub

Private Function GetVolumeName(Drive As String) As String
On Local Error Resume Next
Dim VolName As String, FSys As String, Ret As Long
Dim VolNumber As Long, MCM As Long, FSF As Long
Dim DriveType As Long
Const MaxSize As String = 127
VolName = Space(MaxSize)
FSys = Space(MaxSize)
Ret = GetVolumeInformationA(Drive, VolName, MaxSize, VolNumber, MCM, FSF, FSys, MaxSize)
VolName = Left(VolName, IIf(InStr(VolName, vbNullChar) = 0, 0, InStr(VolName, vbNullChar) - 1))
GetVolumeName = IIf(Ret = 0, "Empty", VolName)
End Function

Private Sub Timer1_Timer()
Call AssembleDriveLetter
End Sub

---

خدا کنه جواب بده !