如何判断光驱中是否有CD？我的全部分了

Question

很多人编的fso的操作函数模块都有这个功能,呆会我给你寄一个

Answer 1

代码：
    Dim x As New Scripting.FileSystemObject
    Dim d As Drive
    
    Set d = x.GetDrive("g:")
    Debug.Print d.IsReady再工程中加入引用micorosoft scripting runtime

Answer 2

以下方法无需引用FileSystemObject
-----------------------------------
获得分区信息并判断是否有CD声明：
Declare Function GetVolumeInformation Lib _
"kernel32" Alias "GetVolumeInformationA" _
(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 LongDeclare Function GetDriveType Lib "kernel32" _
Alias "GetDriveTypeA" (ByVal nDrive As String) As LongPublic Const DRIVE_CDROM = 5
使用：
Dim VolName As String, FSys As String, erg As Long
Dim VolNumber As Long, MCM As Long, FSF As Long
Dim Drive As String, DriveType As Long
VolName = Space(127)
FSys = Space(127)
Drive = "F:\" '设置光驱盘符
DriveType& = GetDriveType(Drive$)
erg& = GetVolumeInformation(Drive$, VolName$, 127&, _
VolNumber&, MCM&, FSF&, FSys$, 127&)
Print "分区名称:" & vbTab & VolName$
Print "序列号:" & vbTab & VolNumber&
Print "最大文件名称长:" & vbTab & vbTab & MCM&
Print "文件系统标志:" & vbTab & vbTab & FSF&
Print "文件系统名称:" & vbTab & FSys$
Print "类型:" & vbTab & DriveType&;
'Is the drive a CDROM, if so, check for a CD
If DriveType& = DRIVE_CDROM Then
If erg& = 0 Then
msgbox "没有 CD "
Else
msgbox "有 CD "
End If
End If

Answer 3

其实做到这一点很简单,就是调用一个API函数:GetDriveType,具体声明如下: 
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
该函数返回系统驱动器类型,返回值为5即为光驱,下面这个例子仅作简单的演示,你可以做进一步的改进以用在您自己的应用程序当中
Private Sub GetCDRomLetter()
Dim DriveNum As Integer
Dim DriveType
Dim CDRom As Integer
Dim DriveLetter As String
Dim i As Byte
DriveNum = 1
Do
DriveNum = DriveNum + 1
DriveLetter = Chr(DriveNum + 65) + ":\"
DriveType = GetDriveType(DriveLetter)
If DriveType = DRIVE_CDROM Then Debug.Print DriveLetter'DRIVE_CDROM=5
Loop Until DriveType = 1'返回值为1,已无可用驱动器
End Sub