CD ROM Detection

[Ali Rizwan]

Hi all,
I have write this program which is used to detect CD ROM.
You just need to add a command button.

[CODE=vb]Option Explicit

Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTy peA" _
(ByVal nDrive As String) As Long

Private Declare Function GetLogicalDrive Strings Lib "kernel32" _
Alias "GetLogicalDriv eStringsA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Const DRIVE_CDROM& = 5

Public Function GetDriveStrings () As String
' Wrapper for calling the GetLogicalDrive Strings api

Dim result As Long ' Result of our API calls
Dim strDrives As String ' String to pass to API call
Dim lenStrDrives As Long ' Length of the above string

' Call GetLogicalDrive Strings with a buffer size of zero to
' find out how large our stringbuffer needs to be
result = GetLogicalDrive Strings(0, strDrives)

strDrives = String(result, 0)
lenStrDrives = result

' Call again with our new buffer
result = GetLogicalDrive Strings(lenStrD rives, strDrives)

If result = 0 Then
' There was some error calling the API
' Pass back an empty string
' NOTE - TODO: Implement proper error handling here
GetDriveStrings = ""
Else
GetDriveStrings = strDrives
End If
End Function

Private Sub Command1_Click( )
Dim strDrives As String

' Find out what drives we have on this machine
strDrives = GetDriveStrings ()

If strDrives = "" Then
' No drives were found
MsgBox "No Drives were found!", vbCritical
Else
' Walk through the string and check the type of each drive
' displaying any cd-rom drives we find
Dim pos As Long
Dim drive As String
Dim drivetype As Long

pos = 1

Do While Not Mid$(strDrives, pos, 1) = Chr(0)
drive = Mid$(strDrives, pos, 3)
pos = pos + 4
drivetype = GetDriveType(dr ive)
If drivetype = DRIVE_CDROM Then
MsgBox "CD-ROM found at drive " & UCase(drive)
End If
Loop
End If
End Sub[/CODE]

Regards
>> ALI <<