• Home
 · 
• Files/File Controls/Input/Output
 · 
• Detect CDROM information using VB

Detect CDROM information using VB

Detect CDROM information using VB

API Declarations




Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const DRIVE_CDROM = 5


Public 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
Public Const SW_NORMAL = 1
Global Const SW_SHOW = 5


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 Long



Rate Detect CDROM information using VB

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

    Dim r As Long
    Dim DriveType As Long
    Dim allDrives As String
    Dim DriveLetter As String
    Dim CDLabel As String
    Dim pos As Integer
    Dim CDfound As Boolean
    allDrives$ = Space$(64)
    r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)
    allDrives$ = Left$(allDrives$, r&)


    Do
        pos% = InStr(allDrives$, Chr$(0))


        If pos% Then
            DriveLetter$ = Left$(allDrives$, pos% - 1)
            allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))
            DriveType& = GetDriveType(DriveLetter$)


            If DriveType& = DRIVE_CDROM Then
                CDfound = True
                rgbGetVolumeInformationRDI DriveLetter$, DrvVolumeName$, DrvSerialNo$
                If DrvVolumeName$ = CDLabeler Then Exit Do
            End If
        End If
    Loop Until allDrives$ = "" Or DrvVolumeName$ = CDLabeler


    If CDfound Then
        cdromdrive = UCase$(DriveLetter$)
    Else
        GetCdDrive = "(none)"
    End If
    GetCdDrive = cdromdrive
End Function




Public Sub rgbGetVolumeInformationRDI(PathName$, DrvVolumeName$, DrvSerialNo$)
    Dim r As Long
    Dim pos As Integer
    Dim HiWord As Long
    Dim HiHexStr As String
    Dim LoWord As Long
    Dim LoHexStr As String
    Dim VolumeSN As Long
    Dim MaxFNLen As Long
    Dim UnusedStr As String
    Dim UnusedVal1 As Long
    Dim UnusedVal2 As Long
    DrvVolumeName$ = Space$(14)
    UnusedStr$ = Space$(32)
    r& = GetVolumeInformation(PathName$, _
    DrvVolumeName$, Len(DrvVolumeName$), VolumeSN&, _
    UnusedVal1&, UnusedVal2&, UnusedStr$, Len(UnusedStr$))
    If r& = 0 Then Exit Sub
    pos% = InStr(DrvVolumeName$, Chr$(0))
    If pos% Then DrvVolumeName$ = Left$(DrvVolumeName$, pos% - 1)
    If Len(Trim$(DrvVolumeName$)) = 0 Then DrvVolumeName$ = "(no label)"
End Sub


Public Function rgbGetVolumeLabel(CDPath$) As String
    Dim r As Long
    Dim DrvVolumeName As String
    Dim pos As Integer
    Dim UnusedVal1 As Long
    Dim UnusedVal2 As Long
    Dim UnusedVal3 As Long
    Dim UnusedStr As String
    DrvVolumeName$ = Space$(14)
    UnusedStr$ = Space$(32)
    pos% = InStr(DrvVolumeName$, Chr$(0))
    If pos% Then DrvVolumeName$ = Left$(DrvVolumeName$, pos% - 1)
    If Len(Trim$(DrvVolumeName$)) = 0 Then DrvVolumeName$ = "(no label)"
    rgbGetVolumeLabel = DrvVolumeName$
End Function

'**************************************
' Name: Copy protect CD's
' Description:It's a step to slightly co
'     py protect your applications on cdrom an
'     d to ensure that your programs are run f
'     rom the cdrom (if it calls external prog
'     rams)...
'(if someone where to jsut do a cd copy this won't do much, but a cd can't be copied and run from the harddrive...)
' By: standby
'
'
' Inputs:n/a
'
' Returns:n/a
'
'Assumes:When you burn your cd, you must
'     put a specific label on that cd for this
'     to work, and you must specify the same l
'     abel here...
'this will search for all cd rom drives, and then look for the right cd...if no cd rom drives or no cdrom drives with the right cd are found it will error out
'***************************************************

'example:


Private Sub Form_Load()
Dim str As String
On Error Resume Next
str = GetCdDrive("programes") & "Fusionv3.exe"  '  programes =label of CD-ROM and Fusionv3.exe is a  file existe in CD-ROM.

If Dir(str) = "" Then   '  if this  file(Fusionv3.exe )don't  existe ,so 
MsgBox "Inserez le CD-ROM  du programme 'Biblio-Tech' ", vbCritical + vbOKOnly, "Erreur!"
End
End If


End Sub


'That's ALL
' Your  Friend ALI JOUNI