the file work only from the CD

[frsm]

good time for all of you

this issue is very important for me and we are very near to achive it

i have a workbook will be copied to CD and i want it to work only from the cd and if it in the hard disks or floopy or flash disk to close before working.
by the help of this forum i reached the following code :

Option Base 0
Private Sub Workbook_Open()
Dim fso As Object, drv As Object, arrdrvTypes
Dim sdrvName As String, sdrvType As String, sdrvLetter As String
Dim ldrvSize As Long, ldrvFreeSpace As Long, sMsg As String
arrdrvTypes = Array("Unknown", "Removable", "Fixed", "Network", "CD-ROM", "RAM Disk")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each drv In fso.drives
    If drv.DriveType = 4 Then
        sdrvLetter = drv.DriveLetter
        If Left(ActiveWorkbook.Path, 1) <> sdrvLetter Then
        ActiveWorkbook.Close
        End If
    End If
Next
MsgBox "Enjoy your time you have  the orginal CD "
End Sub

in this code it testing the workbook's place and take the drive letter then compare it with the cd's letter if it equal the file will open else it will be closed .
the problem somtimes there are more than one cd in the computer , there this code doesn't recognize which letters we need so it will not work well
the requset to allow the code recognize each CD letter and compare it with the workbook's drive letter if it is equal to one of them to work else to close

thank you

 

[Andrew Poulsom]

Untested:

Private Sub Workbook_Open()
    Dim fso As Object, drv As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each drv In fso.drives
        If drv.DriveLetter = Left(ActiveWorkbook.Path, 1) Then
            If drv.DriveType = 4 Then
                MsgBox "Enjoy your time, you have the original CD"
                Exit Sub
            End If
        End If
    Next
    MsgBox "You do not have the original CD"
    ActiveWorkbook.Close
End Sub

 

[frsm]

thank you very very muchhhhhhhhhhhhhhhhhhhhhhhhhhhh