VBA for SaveAs, limited options for filetype, fixed destination folder

[DutchKevin]

Hi All,
I've been searching around a while now and found several "almost what I need" solutions.
The thing I'm working on is a VBA macro that:
- triggers a save-as dialog
- uses the current file name, allows a different name
- limits filetypes in the list to xlsx, xlsm
- allows changing current filetype e.g. from xlsx -> xlsm, or vice versa
- and that starts from a predefined folderlocation on my c-drive, from a variable

So far I've explored options that use Application.Dialogs(xlDialogSaveAs) and Application.FileDialog(msoFileDialogSaveAs) but it never really gets all the way.
Either the destination folder does not "stick", or the file extension filter is failing, or the file type changing is causing error. Each option I test seems to have at least one part from the wish-list missing.
Could anyone please point me in the right direction? I assume that what I attempt here is not impossible ???

Thanks in advance

 

[GWteB]

The custom function below uses the Application.GetSaveAsFilename method, which opens a file dialog, just for the user to determine a destination folder and a file name. Therefore the code has to provide a way to actually save the desired workbook. The code below takes this into account .

Public Function LimitedSaveAs(ByVal argWb As Workbook, ByVal argFolder As String) As String

    Const FILTERS As String = "Excel Workbook (*.xlsx), *.xlsx, " & _
                              "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm"
    
    Dim fso         As Object
    Dim Result      As Variant
    Dim InitialPath As String
    Dim FileExt     As String
    Dim FileFormat  As XlFileFormat
    Dim FilterIndex As Long
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    InitialPath = IIf(Len(argFolder) = 0, argWb.Path & "\", IIf(Right(argFolder, 1) = "\", argFolder, argFolder & "\"))
    If fso.FolderExists(InitialPath) Then
        InitialPath = InitialPath & argWb.Name
    Else
        InitialPath = argWb.FullName
    End If

    If Len(argWb.Path) = 0 Then
        FilterIndex = 1
    Else
        FileExt = Right(InitialPath, Len(InitialPath) - InStrRev(InitialPath, "."))
        Select Case LCase(FileExt)
            Case "xlsx":    FilterIndex = 1
            Case "xlsm":    FilterIndex = 2
            Case Else:      FilterIndex = 1
        End Select
    End If

    Result = Application.GetSaveAsFilename(InitialPath, FILTERS, FilterIndex, "Save as")
    If Not VarType(Result) = vbBoolean Then

        FileExt = Right(Result, Len(Result) - InStrRev(Result, "."))
        Select Case LCase(FileExt)
            Case "xlsx":    FileFormat = xlOpenXMLWorkbook
            Case "xlsm":    FileFormat = xlOpenXMLWorkbookMacroEnabled
            Case Else:      FileFormat = xlOpenXMLWorkbook
        End Select
        Application.DisplayAlerts = False
        argWb.SaveAs FileName:=Result, FileFormat:=FileFormat
        Application.DisplayAlerts = True
        LimitedSaveAs = Result
    Else
        
        ' cancel was pressed
    End If
End Function

Usage example:

Public Sub DutchKevin()

    Dim ResultFile  As String
    Dim FolderName  As String
    Dim wb          As Workbook

    FolderName = "C:\Users\DutchKevin\Documents"    ' <<<< change to suit
    Set wb = ActiveWorkbook                         ' <<<< change to suit

    ResultFile = LimitedSaveAs(wb, FolderName)
    
    If Len(ResultFile) > 0 Then
        MsgBox ResultFile & " has been saved", vbInformation
    Else
        MsgBox "Workbook " & wb.Name & " has not been saved!", vbExclamation
    End If
End Sub

 

[DutchKevin]

Hello GWteB
I did some quick testing. The day is at it's end here, and this looks to do exactly what I need!
How the VBA works, that I need to process a bit further, but it looks very elegant.
Thanks already a lot for helping me forward, and I'll post back any questions I may find tomorrow

 

[GWteB]

Ok, thanks for letting me know.