CODEWITHSUNDEEP
excelvbasavesave-as
Riccardo
Riccardo

Reputation: 13

Save with specific file name and format

I would like to ask your help with this code:

Option Explicit
Private WithEvents App As Excel.Application

Private Sub Workbook_Open()
    Set App = Application
End Sub

Private Sub App_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    App.EnableEvents = False
    With App.Dialogs(xlDialogSaveAs)
        Call .Show(MakeDocName, xlOpenXMLWorkbookMacroEnabled)
    End With
    App.EnableEvents = True
    Cancel = True
End Sub


Function MakeDocName() As String
    Dim theName As String
    Dim pName As String
    Dim pUName As String

    pName = Sheets("DESCRIPTION").Range("b4")
    pUName = UCase(pName)
    theName = pUName & " RN " & Sheets("DESCRIPTION").Range("b2")
    MakeDocName = theName
End Function

Basically what I expect from this code is the possibility to save the file with a specified name and format. The name is taken directly from the "DESCRIPTION" sheet. The format should be .xlsm.

The problem is that the code works not only within ThisWorkbook but also in all the opened Excel files.

Is there any chance to make this code available only for the specified file in which the code is included?

Upvotes: 1

Views: 789

Answers (3)

Riccardo
Riccardo

Reputation: 13

Finally I found a solution. I just removed the application event and used the following code in ThisWorkbook module.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Application.EnableEvents = False
    If Application.ThisWorkbook.Path = "" Then
        With Application.Dialogs(xlDialogSaveAs)
            Call .Show(MakeDocName, xlOpenXMLWorkbookMacroEnabled)
        End With
    Else
        Application.ThisWorkbook.Save
    End If
    Cancel = True
End Sub

Function MakeDocName() As String
    Dim theName As String
    Dim pName As String
    Dim pUName As String
    Dim uscore As String
    uscore = "_"

    pName = Sheets("DESCRIPTION").Range("b4")
    pUName = UCase(pName)

    theName = pUName & " RN " & Sheets("DESCRIPTION").Range("b2")

    MakeDocName = theName
End Function

Upvotes: 0

R3uK
R3uK

Reputation: 14537

You just need to test the Wb object at the start of your event `` with something like this :

If Wb <> ThisWorkbook Then Exit Sub
'Or
If Wb.Name <> ThisWorkbook.Name Then Exit Sub

Or you could place the code of App_WorkbookBeforeSave in Workbook_BeforeSave in ThisWorkBook module, so that it'll only be trigger by this workbook! ;)

Here is your full code :

Option Explicit
Private WithEvents App As Excel.Application

Private Sub Workbook_Open()
    Set App = Application
End Sub

Private Sub App_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If Wb <> ThisWorkbook Then Exit Sub
    'If Wb.Name <> ThisWorkbook.Name Then Exit Sub

    App.EnableEvents = False
    With App.Dialogs(xlDialogSaveAs)
        Call .Show(MakeDocName, xlOpenXMLWorkbookMacroEnabled)
    End With
    App.EnableEvents = True
    Cancel = True
End Sub


Function MakeDocName() As String
    Dim theName As String
    Dim pName As String
    Dim pUName As String

    pName = Sheets("DESCRIPTION").Range("b4")
    pUName = UCase(pName)
    theName = pUName & " RN " & Sheets("DESCRIPTION").Range("b2")
    MakeDocName = theName
End Function

Upvotes: 1

genespos
genespos

Reputation: 3311

You can use

ActiveWorkbook.SaveAs _
Filename:="C:\Allpath\YourFileName", _
FileFormat:= 'HereYourFileFormat" _
CreateBackup:=False

Have a look here for fileformats These are fileformat types for excel2003:

xlCSV
xlCSVMSDOS
xlCurrentPlatformText
xlDBF3
xlDIF
xlExcel2FarEast
xlExcel4
xlAddIn
xlCSVMac
xlCSVWindows
xlDBF2
xlDBF4
xlExcel2
xlExcel3
xlExcel4Workbook
xlExcel5
xlExcel7
xlExcel9795
xlHtml
xlIntlAddIn
xlIntlMacro
xlSYLK
xlTemplate
xlTextMac
xlTextMSDOS
xlTextPrinter
xlTextWindows
xlUnicodeText
xlWebArchive
xlWJ2WD1
xlWJ3
xlWJ3FJ3
xlWK1
xlWK1ALL
xlWK1FMT
xlWK3
xlWK3FM3
xlWK4
xlWKS
xlWorkbookNormal
xlWorks2FarEast
xlWQ1
xlXMLSpreadsheet

Upvotes: 0

Related Questions