by ALI JOUNI (1 Submission)
Category: Files/File Controls/Input/Output
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sat 27th July 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
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
