I'm not a user of Excel so I haven't raised any of the excellent points raised by @IvenBach. This answer is more concerned about separation of concerns and re-usability.
The month name to month number lookup has been consolidated into its own Class which allows a fairly simple process for creating a new MonthNumbers object where January is not month "01". I've also taken the opportunity to use only the first 3 letters of the month name as the keys in the internal lookup dictionary so that the class will work with full and partial names of any case.
Class MonthNumbers
'@PredeclaredId
Option Explicit
Private Type State
NameToNumber As Scripting.Dictionary
End Type
Private s As State
'Private Sub Class_Initialize()
'
' Main.FailIfMeIsNotPredeclaredId Me, MonthNumbers
'
'End Sub
Public Function Make(ByVal NumberArray As Variant, ByVal MonthArray As Variant) As MonthNumbers
With New MonthNumbers
Set Make = .Self(NumberArray, MonthArray)
End With
End Function
Public Function Self(ByVal NumberArray As Variant, ByVal MonthsArray As Variant) As MonthNumbers
If UBound(NumberArray) <> UBound(MonthsArray) Then
Err.Raise vbObjectError + 404, "Months:Self: Arrays must be the same size and have the same Bounds"
End
End If
Dim myItem As Long
Set s.NameToNumber = New Scripting.Dictionary
For myItem = 0 To UBound(NumberArray)
s.NameToNumber.Add LCase$(Left$(Trim$(MonthsArray(myItem))), 3), LCase$(Left$(Trim$(NumberArray(myItem))), 3)
Next
Set Self = Me
End Function
Public Function Number(ByVal MonthName As String) As String
Number = IIf(s.NameToNumber.Exists(LCase$(Left$(MonthName, 3))), s.NameToNumber.Item(LCase$(Left$(MonthName, 3))), vbNullString)
End Function
There are four different types of report in the method 'ComposeFileName' (at least by the way in which the filenames are constructed differently for each report type). To disentangle the logic I created Four classes - Expenses, PreSetting, VacationApplication and WorkingTime. Due to the lack of inheritance in VBA there is a degree of duplicated code between these classes but I feel it is acceptable to bear this duplication for such small classes.
These classes are static in that they only use the PredeclaredId instance. New instances of the Classes are not created (but could be if the code was adapted). I also relocated the getting of the destination path from the SaveAsPdf method to these classes but it may be that this is a step too far.
The destination path and month to month number lookup are injected into the classes Through the Setup Method as I though this might be done once in a session whereas there may be a number of different other reports produced. The Setup method is unusual in that it is a function which returns the PredeclaredId instance. This has been done to simplify simultaneous setup and addition to a holding scripting.dictionary. The method which takes the spreadsheet to be saved is declared as an Interface to allow intellisense and the avoidance of a Select Case or Multi part If ElseIf Else to select which type of report to save.
Class Expenses
'@PredeclaredId
Option Explicit
Private Const EXPENSES_NAME As String = "Reisekosten"
Private Type State
SavePath As String
Months As MonthNumbers
End Type
Private s As State
Implements IPathAndName
Private Function IPathAndName_PathAndName(ByVal ReportSheet As Excel.Worksheet) As String
IPathAndName_PathAndName = PathAndName(ReportSheet)
End Function
Public Function Setup(ByVal SavePath As String, ByRef Months As MonthNumbers) As Expenses
Set s.Months = Months
s.SavePath = SavePath
Set Setup = Me
End Function
Public Function PathAndName(ByRef ReportSheet As Excel.Worksheet) As String
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ReportSheet.Parent
Dim myPresetSheet As Excel.Worksheet
Set myPresetSheet = myWorkbook.Sheets.Item(1)
Dim myActiveSheet As Excel.Worksheet
Set myActiveSheet = myWorkbook.ActiveSheet
Dim myYear As String
myYear = myPresetSheet.Cells.Item(2, 11)
Dim myShortName As String
myShortName = myPresetSheet.Cells.Item(3, 11).Value
PathAndName = _
s.SavePath _
& "\" _
& Mid$(myYear, 3, 2) _
& "-" _
& s.Months.Number(Left$(myActiveSheet.Cells.Item(4, 3).Value, 3)) _
& "_" _
& EXPENSES_NAME _
& "_" _
& myShortName _
& ".pdf"
End Function
Class PreSetting
'@PredeclaredId
Option Explicit
Private Type State
SavePath As String
Months As MonthNumbers
End Type
Private s As State
Implements IPathAndName
Private Function IPathAndName_PathAndName(ByVal ReportSheet As Excel.Worksheet) As String
IPathAndName_PathAndName = PathAndName(ReportSheet)
End Function
Public Function Setup(ByVal SavePath As String, ByVal Months As MonthNumbers) As PreSetting
Set s.Months = Months
s.SavePath = SavePath
Set Setup = Me
End Function
Public Function PathAndName(ByVal ReportSheet As Excel.Worksheet) As String
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ReportSheet.Parent
Dim myPresetSheet As Excel.Worksheet
Set myPresetSheet = myWorkbook.Sheets.[_Default](1)
Dim myActiveSheet As Excel.Worksheet
Set myActiveSheet = myWorkbook.ActiveSheet
Dim myYear As String
myYear = myPresetSheet.Cells.Item(2, 11)
Dim myShortName As String
myShortName = myPresetSheet.Cells.Item(3, 11).Value
PathAndName = _
s.SavePath _
& "\" _
& myYear _
& "-" _
& myActiveSheet.Name _
& "_" _
& myShortName _
& ".pdf"
End Function
Class VacationApplication
'@PredeclaredId
Option Explicit
Private Const VACATION_APPLICATION_NAME _
As String = "Urlaub_Gleittag_Antrag"
Private Type State
SavePath As String
Months As MonthNumbers
End Type
Private s As State
Implements IPathAndName
Private Function IPathAndName_PathAndName(ByVal ReportSheet As Excel.Worksheet) As String
IPathAndName_PathAndName = PathAndName(ReportSheet)
End Function
Public Function Setup(ByVal SavePath As String, ByRef Months As MonthNumbers) As VacationApplication
Set s.Months = Months
s.SavePath = SavePath
Set Setup = Me
End Function
Public Function PathAndName(ByRef ReportSheet As Excel.Worksheet) As String
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ReportSheet.Parent
Dim myPresetSheet As Excel.Worksheet
Set myPresetSheet = myWorkbook.Sheets.[_Default](1)
' Dim myActiveSheet As Excel.Worksheet
' myActiveSheet = myWorkbook.ActiveSheet
Dim myYear As String
myYear = myPresetSheet.Cells.Item(2, 11)
Dim myShortName As String
myShortName = myPresetSheet.Cells.Item(3, 11).Value
PathAndName = _
s.SavePath _
& "\" _
& myYear _
& "_" _
& VACATION_APPLICATION_NAME _
& "_(" _
& Format$(Date) _
& ")_" _
& myShortName _
& ".pdf"
End Function
Class WorkingTime
'@PredeclaredId
Option Explicit
Private Const WORKING_TIME As String = "Arbeitszeit"
Private Type State
SavePath As String
Months As MonthNumbers
End Type
Private s As State
Implements IPathAndName
Private Function IPathAndName_PathAndName(ByVal ReportSheet As Excel.Worksheet) As String
IPathAndName_PathAndName = PathAndName(ReportSheet)
End Function
Private Sub Class_Initialize()
Main.FailIfMeIsNotPredeclaredId Me, WorkingTime
End Sub
Public Function Setup(ByVal SavePath As String, ByVal Months As MonthNumbers) As WorkingTime
Set s.Months = Months
s.SavePath = SavePath
Set Setup = Me
End Function
Private Function PathAndName(ByRef ReportSheet As Excel.Worksheet) As String
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ReportSheet.Parent
Dim myPresetSheet As Excel.Worksheet
Set myPresetSheet = myWorkbook.Sheets.[_Default](1)
Dim myActiveSheet As Excel.Worksheet
Set myActiveSheet = myWorkbook.ActiveSheet
Dim myYear As String
myYear = myPresetSheet.Cells.Item(2, 11)
Dim myShortName As String
myShortName = myPresetSheet.Cells.Item(3, 11).Value
PathAndName = _
s.SavePath _
& "\" _
& Mid$(myYear, 3, 2) _
& "-" _
& s.Months.Number(myActiveSheet.Name) _
& "_" _
& WORKING_TIME _
& "_" _
& myShortName _
& ".pdf"
End Function
Class Interface IPathAndName
Option Explicit
'@Ignore FunctionReturnValueNotUsed
Public Function PathAndName(ByVal ReportSheet As Excel.Worksheet) As String
End Function
[Sighs.... I've just realised that the interface naming is a bit too similar to the Implementation method, but this is a detail that can be resolved later.]
By rights, all of the above classes should contain a Class_Initialize method which detects correct use of the class (i.e. prevents the use of New to create classes if this is not required etc) but this code is rather complicated and hasn't been presented above.
In the final module the Method to save the spreadsheet as a pdf contains code that could be relocated elsewhere, e.g. the initialising of the Months object and the reports dictionary. I've put it in the SaveAsPdf method on this occasion to avoid having yet another method.
Module Main
Option Explicit
Private Const STAFF_EMAIL_ADDRESS = "[email protected]"
Private Type State
Reports As Scripting.Dictionary
Months As MonthNumbers
End Type
Private s As State
Public Sub SaveAsPdf(ByRef ReportSheet As Excel.Worksheet)
If s.Months Is Nothing Then InitialiseMonths
If s.Reports Is Nothing Then InitialiseReports
' This use of an interface is a bit contrived as
' s.Reports.Item(mySheet.Name).PathAndName
' would work just as wel ableit without intellisense
' on the s.Reports.Item(mySheet.Name)
Dim myReport As IPathAndName
Set myReport = s.Reports.Item(ReportSheet.Name)
Dim myPathandName As String
myPathandName = myReport.PathAndName(ReportSheet)
ReportSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
fileName:=myPathandName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Dim myShortName As String
myShortName = Replace(Right$(myPathandName, InStrRev(myPathandName, "\") - 1), ".pdf", vbNullString)
SendAsMail myPathandName, STAFF_EMAIL_ADDRESS, myShortName
End Sub
Private Sub SendAsMail(ByVal PathAndName As String, ByVal Receiver As String, ByVal Subject As String)
Dim outlook As Object
Set outlook = CreateObject("Outlook.Application")
Dim message As Object
Set message = outlook.CreateItem(0)
With message
.Display
.To = Receiver
.CC = vbNullString
.Subject = Subject
.Attachments.Add PathAndName
End With
End Sub
Private Sub InitialiseMonths()
Set s.Months = _
MonthNumbers.Make _
( _
Split("01,02,03,04,05,06,07,08,09,10,11,12", ","), _
Split(" Januar,Februar,März,April,Mai, Juni,Juli, August,September,Oktober,November,Dezember", ",") _
)
' If Month "0"1 happens to be April then
' Set s.Months = _
' MonthNumbers.Make _
' ( _
' Split("10,11,12,01,02,03,04,05,06,07,08,09", ","), _
' Split(" Januar,Februar,März,April,Mai, Juni,Juli, August,September,Oktober,November,Dezember", ",") _
' )
End Sub
Private Sub InitialiseReports()
'Requires a reference to "Windows Script Host Object Model"
Dim myShell As WshShell: Set myShell = New WshShell
' Seperate variable for debugging convenience
Dim myPath As String
myPath = myShell.SpecialFolders.Item("MyDocuments")
s.Reports.Add "Voreinstellungen", PreSetting.Setup(myPath, s.Months)
s.Reports.Add "Urlaubsantrag", VacationApplication.Setup(myPath, s.Months)
s.Reports.Add "Spesen", Expenses.Setup(myPath, s.Months)
s.Reports.Add "Arbeitszeit", WorkingTime.Setup(myPath, s.Months)
End Sub
The code above is clean in that it compiles and shows no Inspection results from RubberDuck. However, as I don't have examples of the spreadsheets I haven't run the code so apologies in advance if there are any logic errors.
I hope folks fine the above useful. I've certainly had a very interesting couple of years reading the RubberDuck blogs which have allowed me to progress from a muddle of poorly constructed subs and functions to start to being able to organise my (hobbyist) code a little better.
