Identify CD-Rom drive

[MD]

Using FileCopy, I'd like to copy a file from a CD-Rom that is always in the
same folder to the hard drive.

Sub TranferFiles()
SourceFile = "E:\folder\MyFile.doc"
DestinationFile = "C:\Temp\MyFile.doc"
FileCopy SourceFile, DestinationFile
End Sub

One problem with this....The CD-Rom drive is not always E from one PC to the
other. So how do I identify the CD-Rom drive so that my code looks like
CD_Drive = ???????
SourceFile = CD_Drive + "\folder\MyFile.doc"

Regards!

Michel

 

[Chip Pearson]

Michel,

In VBA go to the Tools menu, choose References, then scroll down
to Microsoft Scripting Runtime. Put a check next to this and
click OK. Then, you can use code like the following:

Dim FSO As Scripting.FileSystemObject
Dim Drv As Drive
Set FSO = New Scripting.FileSystemObject
For Each Drv In FSO.Drives
If Drv.DriveType = CDRom Then
Debug.Print Drv.DriveLetter
End If
Next Drv



--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com

 

[Bob Phillips]

Michel,

Here is some code that I dapted from my CD-Player that will do it for you.
Got this from Randy Birch originally.

Public Declare Function GetLogicalDriveStrings Lib "kernel32" _
Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Public Declare Function GetDriveType Lib "kernel32" _
Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long

Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6


Private Sub GetCDDrive()
Dim r As Long
Dim sAll As String
Dim sDrive As String
Dim sType As String

'get the list of all available drives
sAll = GetDriveString()

'separate the drive strings and retrieve the drive type
Do Until sAll = Chr$(0)

sDrive = StripNulls(sAll)

Select Case GetDriveType(sDrive)
Case 0: sType = "The drive type cannot be determined"
Case 1: sType = "The root directory does not exist"

Case DRIVE_REMOVABLE:
Select Case Left$(sDrive, 1)
Case "a", "b": sType = "Floppy drive"
Case Else: sType = "Removable drive"
End Select

Case DRIVE_FIXED: sType = "Hard drive; can not be removed"
Case DRIVE_REMOTE: sType = "Remote (network) drive"
Case DRIVE_CDROM: sType = "CD-ROM drive"
Case DRIVE_RAMDISK: sType = "RAM disk"
End Select

If sType = "CD-ROM drive" Then
MsgBox "Drive " & sDrive & " is " & sType
End If

Loop

End Sub


Private Function GetDriveString() As String
Dim sBuffer As String

'possible 26 drives, three characters each, plus trailing null
sBuffer = Space$(26 * 4)

If GetLogicalDriveStrings(Len(sBuffer), sBuffer) Then
GetDriveString = Trim$(sBuffer)
End If

End Function

Private Function StripNulls(Start As String) As String
Dim iPos As Long

iPos = InStr(Start, Chr$(0))

If iPos Then
StripNulls = Mid$(Start, 1, iPos - 1)
Start = Mid$(Start, iPos + 1, Len(Start))
End If

End Function



--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[RB Smissaert]

This won't work in all situations (D could be a hard drive), but it is
simple and you
could expand on it, like looping through all the possible file paths.

Function FindFirstDriveAfterC() As String

Dim i As Byte

For i = 68 To 90
If Len(Dir(Chr(i) & ":\", vbDirectory)) > 0 Then
FindFirstDriveAfterC = Chr(i)
Exit Function
End If
Next

End Function


Sub test()
MsgBox FindFirstDriveAfterC()
End Sub


RBS

 

[RB Smissaert]

If for some reason you want to keep it simple this might be an option:
It is based on the fact that you can't write to a CD-ROM.

Function FindFirstReadOnlyDriveAfterC() As String

Dim i As Byte

On Error GoTo ERROROUT

For i = 68 To 90
StringToTextFile Chr(i) & ":\zxzx.txt", "test"
Kill Chr(i) & ":\zxzx.txt"
Next

ERROROUT:

FindFirstReadOnlyDriveAfterC = Chr(i)

End Function


Sub StringToTextFile(ByVal txtFile As String, _
ByVal strString As String)

Dim hFile As Long

hFile = FreeFile

Open txtFile For Output As hFile
Write #hFile, strString
Close #hFile

End Sub


Sub test()
MsgBox FindFirstReadOnlyDriveAfterC()
End Sub


RBS

 

[MD]

Thank you all for you help

Michel

Michel,

Here is some code that I dapted from my CD-Player that will do it for you.
Got this from Randy Birch originally.

Public Declare Function GetLogicalDriveStrings Lib "kernel32" _
Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Public Declare Function GetDriveType Lib "kernel32" _
Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long

Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6


Private Sub GetCDDrive()
Dim r As Long
Dim sAll As String
Dim sDrive As String
Dim sType As String

'get the list of all available drives
sAll = GetDriveString()

'separate the drive strings and retrieve the drive type
Do Until sAll = Chr$(0)

sDrive = StripNulls(sAll)

Select Case GetDriveType(sDrive)
Case 0: sType = "The drive type cannot be determined"
Case 1: sType = "The root directory does not exist"

Case DRIVE_REMOVABLE:
Select Case Left$(sDrive, 1)
Case "a", "b": sType = "Floppy drive"
Case Else: sType = "Removable drive"
End Select

Case DRIVE_FIXED: sType = "Hard drive; can not be removed"
Case DRIVE_REMOTE: sType = "Remote (network) drive"
Case DRIVE_CDROM: sType = "CD-ROM drive"
Case DRIVE_RAMDISK: sType = "RAM disk"
End Select

If sType = "CD-ROM drive" Then
MsgBox "Drive " & sDrive & " is " & sType
End If

Loop

End Sub


Private Function GetDriveString() As String
Dim sBuffer As String

'possible 26 drives, three characters each, plus trailing null
sBuffer = Space$(26 * 4)

If GetLogicalDriveStrings(Len(sBuffer), sBuffer) Then
GetDriveString = Trim$(sBuffer)
End If

End Function

Private Function StripNulls(Start As String) As String
Dim iPos As Long

iPos = InStr(Start, Chr$(0))

If iPos Then
StripNulls = Mid$(Start, 1, iPos - 1)
Start = Mid$(Start, iPos + 1, Len(Start))
End If

End Function



--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)