dmorse03
asked on
How determine what CD drive user has selected?
I am putting an Excel file on a CD for distribution to several people. One application requires coding to create an absolute link to a file on the CD in the drive in which the user has inserted the CD. eg:
The file is, say: 232.tif
This user's drive is G:\
need coding to determine that the drive is G so that I can create link:
G:\232.tif
The file is, say: 232.tif
This user's drive is G:\
need coding to determine that the drive is G so that I can create link:
G:\232.tif
To create short cut
Option Explicit
Enum ShortCutDest
DeskTop
Programs
StartMenu
StartUp
End Enum
Public Function CreateLink(dest As ShortCutDest, ByVal sName As String, ByVal sPath As String, Optional HotKey As String = "", Optional sIcon As String = "", Optional sWorkingDirectory As String = "", Optional sSubFolder As String = "", Optional WinStyle As Integer = vbNormalFocus)
Dim WshShell As Object
Dim oShellLink As Object
Dim sLinkPath As String
Set WshShell = CreateObject("WScript.Shel l")
Select Case dest
Case DeskTop
sLinkPath = WshShell.SpecialFolders("D esktop")
Case StartMenu
sLinkPath = WshShell.SpecialFolders("S tartMenu")
Case StartUp
sLinkPath = WshShell.SpecialFolders("S tartUp")
Case Programs
sLinkPath = WshShell.SpecialFolders("P rograms")
End Select
On Error Resume Next
If sSubFolder <> "" Then
sLinkPath = sLinkPath & "\" & sSubFolder
If Dir(sLinkPath) = "" Then MkDir sLinkPath
End If
On Error GoTo 0
Set oShellLink = WshShell.CreateShortCut(sL inkPath & "\" & sName & ".lnk")
oShellLink.WindowStyle = WinStyle
oShellLink.HotKey = sHotKey
oShellLink.TargetPath = sPath
oShellLink.IconLocation = sIcon
oShellLink.Description = sName
oShellLink.WorkingDirector y = sWorkingDirectory
oShellLink.Save
Set oShellLink = Nothing
Set WshShell = Nothing
End Function
'Usage
Private Sub Command1_Click()
CreateLink DeskTop, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
CreateLink StartMenu, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
CreateLink StartUp, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
CreateLink Programs, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows", "WinCalc"
CreateLink Programs, "Calculator Help", "c:\windows\help\calc.hlp" , "", "winhlp32.exe,0", "c:\windows\help", "WinCalc"
CreateLink Programs, "Visit our web site", "https://www.experts-exchange.com", , "shdocvw.dll,0", , "WinCalc", vbMaximizedFocus
End Sub
Option Explicit
Enum ShortCutDest
DeskTop
Programs
StartMenu
StartUp
End Enum
Public Function CreateLink(dest As ShortCutDest, ByVal sName As String, ByVal sPath As String, Optional HotKey As String = "", Optional sIcon As String = "", Optional sWorkingDirectory As String = "", Optional sSubFolder As String = "", Optional WinStyle As Integer = vbNormalFocus)
Dim WshShell As Object
Dim oShellLink As Object
Dim sLinkPath As String
Set WshShell = CreateObject("WScript.Shel
Select Case dest
Case DeskTop
sLinkPath = WshShell.SpecialFolders("D
Case StartMenu
sLinkPath = WshShell.SpecialFolders("S
Case StartUp
sLinkPath = WshShell.SpecialFolders("S
Case Programs
sLinkPath = WshShell.SpecialFolders("P
End Select
On Error Resume Next
If sSubFolder <> "" Then
sLinkPath = sLinkPath & "\" & sSubFolder
If Dir(sLinkPath) = "" Then MkDir sLinkPath
End If
On Error GoTo 0
Set oShellLink = WshShell.CreateShortCut(sL
oShellLink.WindowStyle = WinStyle
oShellLink.HotKey = sHotKey
oShellLink.TargetPath = sPath
oShellLink.IconLocation = sIcon
oShellLink.Description = sName
oShellLink.WorkingDirector
oShellLink.Save
Set oShellLink = Nothing
Set WshShell = Nothing
End Function
'Usage
Private Sub Command1_Click()
CreateLink DeskTop, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
CreateLink StartMenu, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
CreateLink StartUp, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
CreateLink Programs, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows", "WinCalc"
CreateLink Programs, "Calculator Help", "c:\windows\help\calc.hlp"
CreateLink Programs, "Visit our web site", "https://www.experts-exchange.com", , "shdocvw.dll,0", , "WinCalc", vbMaximizedFocus
End Sub
App.Path gives you the path where the application was run from.
Try this code
Function ShowDriveType
Dim fso, d, dc, s, n
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set dc = fso.Drives
For Each d in dc
if d.drivetype = 4 then exit for
Next
ShowDriveType = d.driveletter
End Function
msgbox showdrivetype
Function ShowDriveType
Dim fso, d, dc, s, n
Set fso = CreateObject("Scripting.Fi
Set dc = fso.Drives
For Each d in dc
if d.drivetype = 4 then exit for
Next
ShowDriveType = d.driveletter
End Function
msgbox showdrivetype
iozturk: What if the user has more than one cd-rom drive (for instance I have). Then you are not sure to get the right one!
DrTech: What if application is in HDD and 232.tif is in CD? Then you are not sure you are getting right one:)
But my code can be extended as
Function ShowDriveType
Dim fso, d, dc, s, n
dim flag as boolean
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set dc = fso.Drives
flag=false
For Each d in dc
if d.drivetype = 4 then
if fso.fileexists (d.drivename & ":\232.tif") then exit for
flag=true
end if
Next
if flag=true then
ShowDriveType = d.driveletter
else
ShowDriveType = "Cannaot find correct drive"
end if
OK?
But my code can be extended as
Function ShowDriveType
Dim fso, d, dc, s, n
dim flag as boolean
Set fso = CreateObject("Scripting.Fi
Set dc = fso.Drives
flag=false
For Each d in dc
if d.drivetype = 4 then
if fso.fileexists (d.drivename & ":\232.tif") then exit for
flag=true
end if
Next
if flag=true then
ShowDriveType = d.driveletter
else
ShowDriveType = "Cannaot find correct drive"
end if
OK?
Agree! But the way I read the question, the application is run from the cd.
dmorse03, please clarify!
dmorse03, please clarify!
There is a typo! Pls. try this
Function ShowDriveType
Dim fso, d, dc, s, n
dim flag as boolean
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set dc = fso.Drives
flag=false
For Each d in dc
if d.drivetype = 4 then
if fso.fileexists (d.drivename & ":\232.tif") then
flag=true
exit for
end if
end if
Next
if flag=true then
ShowDriveType = d.driveletter
else
ShowDriveType = "Cannaot find correct drive"
end if
End Function
Function ShowDriveType
Dim fso, d, dc, s, n
dim flag as boolean
Set fso = CreateObject("Scripting.Fi
Set dc = fso.Drives
flag=false
For Each d in dc
if d.drivetype = 4 then
if fso.fileexists (d.drivename & ":\232.tif") then
flag=true
exit for
end if
end if
Next
if flag=true then
ShowDriveType = d.driveletter
else
ShowDriveType = "Cannaot find correct drive"
end if
End Function
ASKER
When executing this line:
if fso.fileexists (d.drivename & ":\232.tif") then
I get this error:
Run Time error '438'
Object doesn't support this property or method
^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^ ^^^^^^^^^^ ^^^^^^^^^^
I could put the entire Excel file on web storage for you to examine, but it is 930 Kb!
Incidently, yes the Excel file and all the fotos will be on CD. Also, most of the people who will be using this will use D:\ as the CD drive. But some will not. My Cd drives, for instance, are J:\ and K:\.
if fso.fileexists (d.drivename & ":\232.tif") then
I get this error:
Run Time error '438'
Object doesn't support this property or method
^^^^^^^^^^^^^^^^^^^^^^^^^^
I could put the entire Excel file on web storage for you to examine, but it is 930 Kb!
Incidently, yes the Excel file and all the fotos will be on CD. Also, most of the people who will be using this will use D:\ as the CD drive. But some will not. My Cd drives, for instance, are J:\ and K:\.
Sorry change d.drivename to d.driveletter
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Quote:
--------------------------
Originally Posted by Iceplug
So, if you are running from the Excel macro, then
Application.ActiveWorkbook
--------------------------
^^^^^^^^^^^^^^^^^^^^^^^^^^
I owe you big time. I have been on this project since last June. Many forums have helped me but you supplied the final link I needed to finish it. So simple (if you know what you are doing). I now have 600+ family fotos on CD along with an Excel control program to allow the user to create a list of fotos per his criteria (Aunt Jane, eg) and run this list as a slideshow (your link).
Don
Cortland, NY
ASKER
I originally posted this question. There is a wealth of information here. But the method I finally chose was from another source. The post is listed as "unlocked". I do not know how to close it out under the circumstances as I did not actually use any of the answers herein. But I do appreciate all the response I got here.
What solution did you use?
ASKER
This is the suggestion I was given:
Application.ActiveWorkbook .Path
This is my final coding:
FindDrive:
DriveID = Application.ActiveWorkbook .Path
Range("U5").Select 'Select your first data cell
Do Until ActiveCell.Value = ""
ActiveCell.Value = DriveID & "\" & ActiveCell.Value & ".tif" 'Grab current value of the cell, Show path, append '.TIF', & replace it
ActiveCell.Offset(1, 0).Select 'Move to next cell
Loop
Application.ActiveWorkbook
This is my final coding:
FindDrive:
DriveID = Application.ActiveWorkbook
Range("U5").Select 'Select your first data cell
Do Until ActiveCell.Value = ""
ActiveCell.Value = DriveID & "\" & ActiveCell.Value & ".tif" 'Grab current value of the cell, Show path, append '.TIF', & replace it
ActiveCell.Offset(1, 0).Select 'Move to next cell
Loop
Debug.Print Mid(App.Path, 1, 3) & "232.tif"
End Sub