Prevent saving to Desktop

[sharky12345]

I'm using this to browse to a folder to save the current workbook;

Function GetInstallFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Toolbox"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetInstallFolder = sItem
NewInstallFrm.TextPath.Value = sItem
Set fldr = Nothing
End Function

Is there a way I can prevent the user from choosing to save on their desktop?

 

[wideboydixon]

Try this:

Function GetInstallFolder() As String

Dim fldr As FileDialog
Dim sItem As String
Dim sDesktop As String
Dim bValid As Boolean

sDesktop = Environ("USERPROFILE") & "\Desktop"

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
Do
    sItem = ""
    bValid = True
    With fldr
        .Title = "Toolbox"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    If StrComp(Left$(sItem, Len(sDesktop)), sDesktop, vbTextCompare) = 0 Then
        bValid = False
        MsgBox "Not allowed to save on the desktop", vbExclamation + vbOKOnly
    End If
Loop Until bValid

GetInstallFolder = sItem
NewInstallFrm.TextPath.Value = sItem
Set fldr = Nothing

End Function

WBD

 

[sharky12345]

Works a treat - thanks!