Solved: Redirect save when given drive is not accessible

[perhol]

In an account-sheet i have used code found in this thread
http://www.vbaexpress.com/forum/showthread.php?t=11572
to make sure that users save account-sheets in right drive and folder and with a filename that identify the sheet correctly.

In this thread
http://www.vbaexpress.com/forum/showthread.php?t=19397
I've got some help to change the code to my purpose.

In some rare instances the given drive G: is not accessible (2 times in the last 6 month). The drive is on a fileserver, and it fails when netconnection fail.

In these cases users will give up saving the account sheet, and their work will be lost.

To resolve this i need code to check if the drive is accessible, and if it is not accessible, change the saving path to the desktop like this:
[vba]"current users desktop" & Sheets("Kasserapport").Range("D2").Text _
& Format(Sheets("Kasserapport").Range("A4"), "mm-yyyy") & _
" " & Sheets("Kasserapport").Range("D2").Text & ".xls"[/vba]
OS is Windows XP Pro DK

Can anyone help me with that?

Here is the code for saving as it is now:
[vba]Sub GemSom()
Dim ws As Worksheet
Set ws = Sheets("Kasserapport")
If Test(ws) = False Then
With Sheets("Kasserapport")
ActiveWorkbook.SaveAs CheckMakePath("G:\" & _
Sheets("Kasserapport").Range("H4").Text & "-huset" & "\" & "Beboere" & "\" & _
Sheets("Kasserapport").Range("D2").Text & "\" & "Regnskab" & "\" & _
Format(Sheets("Kasserapport").Range("A4"), "yyyy")) & _
"Regnskab " & Format(Sheets("Kasserapport").Range("A4"), "mm-yyyy") & _
" " & Sheets("Kasserapport").Range("D2").Text & ".xls"
End With
Else
MsgBox ("Udfyld f?rst Beboernavn og Startdato.")
End If
End Sub

Function Test(ws As Worksheet) As Boolean
If ws.Range("A4") = "" Or ws.Range("A4") = "01.01.00" Or ws.Range("D2") = "" Or ws.Range("D2") = "V?lg Beboernavn" Then Test = True
End Function

Function CheckMakePath(ByVal vPath As String) As String
Dim PathSep As Long, oPS As Long
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
PathSep = InStr(3, vPath, "\") 'Position af drev-seperatoren i stien
If PathSep = 0 Then Exit Function 'Ugyldig sti
Do
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\") 'Position af folder
If PathSep = 0 Then Exit Do
If Len(Dir(Left(vPath, PathSep), vbDirectory)) = 0 Then Exit Do 'check stien
Loop
Do Until PathSep = 0
MkDir Left(vPath, PathSep)
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\")
Loop
CheckMakePath = vPath
End Function[/vba]
Underlined code is highlighted when trying to save with the drive not accessible!

[Simon Lloyd]

A year or so ago i came across some code to check the staus of all drives available to your PC:
[VBA]
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_ABSENT = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
' returns errors for UNC Path
Private Const ERROR_BAD_DEVICE = 1200&
Private Const ERROR_CONNECTION_UNAVAIL = 1201&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NOT_SUPPORTED = 50&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const NO_ERROR = 0

Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _
"WNetGetConnectionA" (ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _
"GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long
Private Function fGetDrives() As String
'Returns all mapped drives
Dim lngRet As Long
Dim strDrives As String * 255
Dim lngTmp As Long
lngTmp = Len(strDrives)
lngRet = GetLogicalDriveStrings(lngTmp, strDrives)
fGetDrives = Left(strDrives, lngRet)
End Function
Private Function fGetUNCPath(strDriveLetter As String) As String
On Local Error GoTo fGetUNCPath_Err

Dim Msg As String, lngReturn As Long
Dim lpszLocalName As String
Dim lpszRemoteName As String
Dim cbRemoteName As Long
lpszLocalName = strDriveLetter
lpszRemoteName = String$(255, Chr$(32))
cbRemoteName = Len(lpszRemoteName)
lngReturn = WNetGetConnection(lpszLocalName, lpszRemoteName, _
cbRemoteName)
Select Case lngReturn
Case ERROR_BAD_DEVICE
Msg = "Error: Bad Device"
Case ERROR_CONNECTION_UNAVAIL
Msg = "Error: Connection Un-Available"
Case ERROR_EXTENDED_ERROR
Msg = "Error: Extended Error"
Case ERROR_MORE_DATA
Msg = "Error: More Data"
Case ERROR_NOT_SUPPORTED
Msg = "Error: Feature not Supported"
Case ERROR_NO_NET_OR_BAD_PATH
Msg = "Error: No Network Available or Bad Path"

Case ERROR_NO_NETWORK
Msg = "Error: No Network Available"
Case ERROR_NOT_CONNECTED
Msg = "Error: Not Connected"
Case NO_ERROR
' all is successful...
End Select
If Len(Msg) Then
MsgBox Msg, vbInformation
Else
fGetUNCPath = Left$(lpszRemoteName, cbRemoteName)
End If
fGetUNCPath_End:
Exit Function
fGetUNCPath_Err:
MsgBox Err.Description, vbInformation
Resume fGetUNCPath_End
End Function

Private Function fDriveType(strDriveName As String) As String
Dim lngRet As Long
Dim strDrive As String
lngRet = GetDriveType(strDriveName)
Select Case lngRet
Case DRIVE_UNKNOWN 'The drive type cannot be determined.
strDrive = "Unknown Drive Type"
Case DRIVE_ABSENT 'The root directory does not exist.
strDrive = "Drive does not exist"
Case DRIVE_REMOVABLE 'The drive can be removed from the drive.
strDrive = "Removable Media"
Case DRIVE_FIXED 'The disk cannot be removed from the drive.
strDrive = "Fixed Drive"
Case DRIVE_REMOTE 'The drive is a remote (network) drive.
strDrive = "Network Drive"
Case DRIVE_CDROM 'The drive is a CD-ROM drive.
strDrive = "CD Rom"
Case DRIVE_RAMDISK 'The drive is a RAM disk.
strDrive = "Ram Disk"
End Select
fDriveType = strDrive
End Function

Sub sListAllDrives()
Dim strAllDrives As String
Dim strTmp As String
strAllDrives = fGetDrives
If strAllDrives <> "" Then
Do
strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1)
strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1)
Select Case fDriveType(strTmp)
Case "Removable Media":
Debug.Print "Removable drive : " & strTmp
Case "CD Rom":
Debug.Print " CD Rom drive : " & strTmp
Case "Fixed Drive":
Debug.Print " Local drive : " & strTmp
Case "Network Drive":
Debug.Print " Network drive : " & strTmp
Debug.Print " UNC Path : " & _
fGetUNCPath(Left$(strTmp, Len(strTmp) - 1))
End Select
Loop While strAllDrives <> ""
End If
End Sub

Private Sub Form_Load()
Debug.Print "All available drives: "
sListAllDrives
End Sub
[/VBA]this will display the available drives in the immediates window in the vba, you should be able to adapt the code to save to the available network drive.

[Simon Lloyd]

You can check for mapped drives using the code below but you have to set a reference to WSHControllerLibrary

[VBA]
Sub NetworkMapDrive()
Set WshNetwork = CreateObject("WScript.Network")
Set oDrives = WshNetwork.EnumNetworkDrives
DrivesStr = "Network drive Mappings:" & Chr(13)
For i = 0 To oDrives.Count - 1 Step 2
DrivesStr = DrivesStr & "Drive " & oDrives.Item(i) & " = " & oDrives.Item(i + 1) & Chr(13)
Next
MsgBox DrivesStr
End Sub

[/VBA]
Again not my code but something i picked up and used in another project!

[perhol]

The necessary drive is always G:
If G: is not available save should be redirected to the users desktop.
So code only need to test availability of drive G:.
If drive G: is available, save using the sub GemSom().
If drive G: is not available, save using the sub XGemSom() containing path to users desktop.

[perhol]

found this on MSDN.

[vba]Function ReportDriveStatus(drv)

Dim fso, msg

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.DriveExists(drv) Then

msg = ("Drive " & UCase(drv) & " exists.")

Else

msg = ("Drive " & UCase(drv) & " doesn't exist.")

End If

ReportDriveStatus = msg

End Function[/vba] But how do i use it?

[perhol]

Found and modified some code sligtly. It seemes to work.
I tested it on a harddisk mounted via USB and partitioned to contain a drive G:.
Have to test it on work where drive G: is at dirve on a fileserver.

Here it is:
[VBA]Sub DRVExists()
If DExists("g") = 2 Then MsgBox "The G: drive exists"
If DExists("g") = 0 Then MsgBox "The G: drive dowes not exists", vbExclamation,
End Sub

Public Function DExists(OrigFile As String)
Dim fs, d
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.driveexists(OrigFile) = True Then
Set d = fs.getdrive(OrigFile)
DExists = 1
If d.isready = True Then
DExists = 2
Exit Function
End If
Else
DExists = 0
End If
End Function
[/VBA]

[Simon Lloyd]

Perhol thanks for posting back your solution.

[perhol]

Solutions is what i like.

[RonMcK]

Solutions is what i like.

So, how did you integrate your solution for determining whether or not the G: drive is available with your code for saving to the desktop when it is unavailable?

Thanks!

[perhol]

That i have not done yet, But it will have to be something like this:


Choosing File -> Save or File -> Save As call an Sub Workbook_BeforeSave that in turn call the Sub DRVExists.

If drive G exists Sub DRVExists call sub Save1
If drive G does not exists Sub DRVExists call sub Save2

Sub Save1 is shown under the name GemSom on top of this thread.
Sub Save2 is not yet made. Because the template for the account-sheet is used by some 30 persons, i want to make the Sub Save2 save the file on the current users desktop, and i still have to find the code for doing that!

[Simon Lloyd]

The code to save to users desktop would be something like:
[VBA]
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\" & Environ("username") & _
"\Desktop\" & ThisWorkbook.Name, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
[/VBA]