Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Sub Command1_Click()
Dim msg As String, I As Long
msg = ""
For I = 0 To 25
temp = Chr(65 + I) & ":\"
If GetDriveType(temp) = 5 Then msg = msg & vbCrLf & temp
Next
MsgBox msg, 64, "CDROM"
End Sub
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
Private Function IsCDRom(ByVal sDriver As String) As Boolean
Select Case GetDriveType(sDriver)
Case 2: IsCDRom = False ' "Removable"
Case 3: IsCDRom = False ' "Drive Fixed"
Case Is = 4: IsCDRom = False ' "Remote"
Case Is = 5: IsCDRom = True ' "Cd-Rom"
Case Is = 6: IsCDRom = False ' "Ram disk"
Case Else: IsCDRom = False ' "Unrecognized"
End Select
End Function
Private Function GetCDRom() As String
Dim LDs As Long, Cnt As Long, sDriver As String
LDs = GetLogicalDrives
For Cnt = 0 To 25
If (LDs And 2 ^ Cnt) <> 0 Then
sDriver = Chr$(65 + Cnt) & ":\"
If IsCDRom(sDriver) Then
Run sDriver
End If
End If
Next Cnt
End Function
Option Explicit
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Sub Form_Click()
Dim StrDrive As String '盘符串(A:\ C:\ D:\...)
Dim DriveID As String '盘符(如:A:\)
StrDrive = String(100, Chr$(0)) '初始化盘符串
Call GetLogicalDriveStrings(100, StrDrive) '返回盘符串
Dim i As Integer
'返回光盘盘符到数组
For i = 1 To 100 Step 4 '注意这里是4
DriveID = Mid(StrDrive, i, 3) '枚举盘符
If DriveID = Chr$(0) & Chr(0) & Chr(0) Then Exit For '没有盘符,即时退出循环
'Debug.Print DriveID
If GetDriveType(DriveID) = 5 Then Call ShellPro(DriveID)
'如果枚举到的盘是CD-ROM,转到 ShellPro 子程序
Next i
End Sub
'子程序:::::打开文件
Sub ShellPro(DrivePro As String)
On Error GoTo Err_File:
If Not IsEmptyCDROM(DrivePro) Then
Shell (DrivePro & "Hello.exe") '打开文件路径
Unload Me
End '并结束本程序
Else
Debug.Print "cdrom empty"
End If
Err_File:
If Err.Description = "错语的文件名或号码" Then Exit Sub
End Sub
Function IsEmptyCDROM(sDrive As String)
Dim s
On Error GoTo ErrHandle
s = Dir(sDrive + "*.*")
IsEmptyCDROM = False
Exit Function
ErrHandle:
IsEmptyCDROM = True
End Function
在工程中添加了Scripting.FileSystemObject后就可以用下面的代码了:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set dr = FSO.Drives
For Each d In dr
if d.drivetype=4 then
print d.driveletter & ":" & "是光驱。"
end if
Next d
简单吧。