Save workbook To any USB Drive no matter what drive letter

[pano]

Hi all, I have tried the search and cannot get any of the other VBA
macros to work re this subject!!

I want to be able to press a button on a sheet on my workbook and have
a macro save the workbook to a USB drive which could come up as either
drive D - E or F. No prompts just save a copy.

Any help at all would be appreciated immensely as I dont have a clue
re VBA. I'm sure that someone must have code that works.

This is the last thing I need to complete the project.

Thanks in advance
Stephen

 

[Dennis]

Try this user defined macro code assigned to a button and once it works for
you simply put your saving code in place of the msgbox code.

Sub Get_Drive_Info()
On Error Resume Next
Dim i As Integer

Set fs = CreateObject("Scripting.FileSystemObject")
For i = 67 To 90
Set drspec = fs.GetDrive(Chr(i))
If drspec.drivetype = 1 Then
MsgBox "Drive " & Chr(i) & " is the removable drive"
i = 90
End If
Next i
End Sub

 

[Nigel]

The following link shows how to get the first CD-ROM drive, these have an ID
of 5; a removable drive is ID = 2 so change the code to suit.

http://support.microsoft.com/kb/q180766/

 

[Dylan]

Using Dennis's Code to get the Drive letter you can use this:

Open the Workbook using Alt+F11 and create a new Workbook_BeforeSave event
and paste the following into the Event SUB

Dim sPath As String
Dim sFilename As String
Dim i As Integer

Application.ScreenUpdating = False
On Error Resume Next

'Backup to Flashdrive
Set fs = CreateObject("Scripting.FileSystemObject")
For i = 67 To 90
Set drspec = fs.GetDrive(Chr(i))
If drspec.drivetype = 1 Then

sPath = Chr(i) & ":\Backups\"
sFilename = "Personal Action Planner " & _
Format(DateSerial(Year(Date), Month(Date), _
Day(Date)), "dd MM yy") & ".xls"

ActiveWorkbook.SaveCopyAs sPath & sFilename

i = 90
End If
Next i

Application.ScreenUpdating = True

'Regards Dylan

 

[Peter T]

Trouble is a Floppy is also considered as "removable". If fitted, assuming
the floppy is always A or B here is a simplified routine that checks "types"
of drive letters from D-Z. Of course there are other types of removable
drives besides floppy & USB.

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

Private Const DRIVE_REMOVABLE As Long = 2
'Private Const DRIVE_FIXED = 3
'Private Const DRIVE_REMOTE = 4 ' eg network
'Private Const DRIVE_CDROM = 5
'Private Const DRIVE_RAMDISK = 6

Function Get1stRemovableAfterC(sDrive) As Boolean
Dim nDriveType As Long
Dim i As Long
For i = Asc("D") To Asc("Z")
sLetter = Chr(i) & ":\"
nDriveType = GetDriveType(sLetter)
If nDriveType = DRIVE_REMOVABLE Then
sDrive = sLetter
Get1stRemovableAfterC = True
Exit Function
End If
Next
End Function


Sub test()
Dim sDrive As String

If Get1stRemovableAfterC(sDrive) Then
MsgBox sDrive
Else
MsgBox "not found"
End If

End Sub

Regards,
Peter T

 

[pano]

Hi, this is the macro which I used before the security USB drives came
in which used to be always D drive for the USB key.
I have tried to incorporate it into the Macro Dennis gave to no avail.
Your code Denis does give me the MSG BOX up which knows that it is D
or E, but from their I'm lost
Any Help appreciated

Sub AASAVETOSTICK()
Application.DisplayAlerts = False
ChDir "D:\"
ActiveWorkbook.SaveAs Filename:="D:\July.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=True
Application.DisplayAlerts = True
End Sub

DENNIS MACRO

Sub Get_Drive_Info()
On Error Resume Next
Dim i As Integer


Set fs = CreateObject("Scripting.FileSystemObject")
For i = 67 To 90
Set drspec = fs.GetDrive(Chr(i))
If drspec.drivetype = 1 Then
MsgBox "Drive " & Chr(i) & " is the removable drive"
i = 90
End If
Next i
End Sub

 

[Dylan]

Peter

Good point! External CDwriters, digital cameras etc. are also classed as USB
Mass storage devices.

Dylan

 

[pano]

Is anyone able to help with joing the code together so it works????

Thanks

 

[pano]

For all who have searched the archives and the net & found nothing
complete.
The following code works. Will save the excel file to personal.xls on
your USB drive no matter what letter drive it is.

Sub Save_to_usb_drive()
On Error Resume Next
Dim i As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
For i = 67 To 90
Set drspec = fs.GetDrive(Chr(i))
If drspec.drivetype = 1 Then

' MsgBox "Drive " & Chr(i) & " is the removable drive"
sPath = Chr(i) & ":\"
sFilename = "Personal.xls " & _
Format(DateSerial(Year(Date), Month(Date), _
Day(Date)), "dd MM yy") & ".xls"
ActiveWorkbook.SaveCopyAs sPath & sFilename
i = 90

End If
Next i
End Sub


Thanks members for all your help and suggestions.....

 

[Dylan]

Pano

It also adds the current date to the filename.

sFilename = "Personal.xls " & _
Format(DateSerial(Year(Date), Month(Date), _
Day(Date)), "dd MM yy") & ".xls"

Regards
Dylan