8
\$\begingroup\$

As the year comes to an end our company need new time-sheets for the new year. Because this is my task to do, I thought I would do my collegues something good by automating some tasks they would otherwise need to do manually.

Until now we had a worksheet for presettings, like setting employee-name, ident-number, remaining holidays and over-time. The users then had to print this sheet, sign it and scan it to send it to our staff-email adress.

Additionally, they enter each day their working and break times and at the first day of the new month they have to print it, sign it and send it to our staff-email adress. They have to do the same for their expenses and for their vacation applications.

To automate these tasks I have added 2 buttons to each of the sheets, one button to print the current sheet with just

Sub PrintActiveSheet()
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
End Sub  

as the code behind.

The other button to save the sheet as pdf and mail it has this code behind

Private Const January As String = "Januar"
Private Const February As String = "Februar"
Private Const March As String = "März"
Private Const April As String = "April"
Private Const May As String = "Mai"
Private Const June As String = "Juni"
Private Const July As String = "Juli"
Private Const August As String = "August"
Private Const September As String = "September"
Private Const October As String = "Oktober"
Private Const November As String = "November"
Private Const December As String = "Dezember"
Private Const PreSetting As String = "Voreinstellungen"
Private Const VacationApplication As String = "Urlaubsantrag"
Private Const VacationApplicationName As String = "Urlaub_Gleittag_Antrag"
Private Const Expenses As String = "Spesen"
Private Const ExpensesName As String = "Reisekosten"
Private Const WorkingTime As String = "Arbeitszeit"
Private Const StaffEmailAdress = "StaffEmail@Company.org"

Sub SaveAsPdf()

    Dim presetSheet As Worksheet
    Set presetSheet = ActiveWorkbook.Sheets(1)

    Dim shortName As String
    shortName = ComposeFileName(presetSheet)

    Dim fileName As String
    Dim shell As Object
    Set shell = CreateObject("WScript.Shell")

    fileName = shell.SpecialFolders("MyDocuments") + "\" + shortName + ".pdf"

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
        fileName, Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

    SendAsMail fileName, StaffEmailAdress, shortName

End Sub
Private Sub SendAsMail(fileName As String, receiver As String, 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 = ""
        .subject = subject
        .Attachments.Add fileName
    End With
End Sub

Private Function ComposeFileName(presetSheet As Worksheet) As String
    Dim sheetName As String
    sheetName = ActiveSheet.Name

    Dim year As String
    year = presetSheet.Cells(2, 11)

    Dim shortName As String
    shortName = presetSheet.Cells(3, 11).Value

    If sheetName = PreSetting Then
        ComposeFileName = year + "_" + sheetName + "_" + shortName
        Exit Function
    End If
    If sheetName = Expenses Then
        ComposeFileName = Mid(year, 3) + "-" + FetchMonthNumber(ActiveSheet.Cells(4, 3).Value) + "_" + ExpensesName + "_" + shortName
        Exit Function
    End If
    If sheetName = VacationApplication Then
        ComposeFileName = year + "_" + VacationApplicationName + "_(" + Format(Date) + ")_" + shortName
        Exit Function
    End If

    ComposeFileName = Mid(year, 3) + "-" + FetchMonthNumber(sheetName) + "_" + WorkingTime + "_" + shortName
    Exit Function

End Function

Private Function FetchMonthNumber(monthName As String) As String
    If monthName = January Then
        FetchMonthNumber = "01"
        Exit Function
    End If
    If monthName = February Then
        FetchMonthNumber = "02"
        Exit Function
    End If
    If monthName = March Then
        FetchMonthNumber = "03"
        Exit Function
    End If
    If monthName = April Then
        FetchMonthNumber = "04"
        Exit Function
    End If
    If monthName = May Then
        FetchMonthNumber = "05"
        Exit Function
    End If
    If monthName = June Then
        FetchMonthNumber = "06"
        Exit Function
    End If
    If monthName = July Then
        FetchMonthNumber = "07"
        Exit Function
    End If
    If monthName = August Then
        FetchMonthNumber = "08"
        Exit Function
    End If
    If monthName = September Then
        FetchMonthNumber = "09"
        Exit Function
    End If
    If monthName = October Then
        FetchMonthNumber = "10"
        Exit Function
    End If
    If monthName = November Then
        FetchMonthNumber = "11"
        Exit Function
    End If
    If monthName = December Then
        FetchMonthNumber = "12"
        Exit Function
    End If
    FetchMonthNumber = ""
End Function

I imagine there can something be improved and like always I am open for suggestion about any aspect of the code.

\$\endgroup\$
8
+200
\$\begingroup\$

All your arguments can/should be passed ByVal. As they are presently written they are implicitly ByRef, the default when neither is specified. You want them written ByVal since you're accessing them and not changing them.

Use of "" can be rewritten as vbNullString. "" leaves doubt as possibly the string had contents previously but were possibly removed accidentally. Maybe? vbNullstring makes it unambiguous that it's intentional.

Sub SaveAsPdf is implicitly public. Explicitly set it to public with Public Sub SaveAsPdf() so there's no doubt you intended it to be this way.

Mid can be written as the string version Mid$ because year is declared as a string.

Within ComposeFileName you are using the ActiveSheet object. It's better to explicitly supply this dependency as an argument because right now it's an implicit dependency that needs to be known about. This is what it would look like at the call site ComposeFileName(ActiveWorkbook.Sheets(1), ActiveSheet) and below is the rewritten function signature. ***Note that ActiveWorkbook.Sheets(1) should be referenced by its CodeName as explained later.

Private Function ComposeFileName(ByVal presetWorksheet As Worksheet, ByVal happenedToBeTheActiveSheet As Worksheet) As String

Again within ComposeFileName you have year = presetSheet.Cells(2, 11).Value2 which is a problem waiting to occur. What happens if you insert a row above that cell, or a column to the left of it? You're now referencing an incorrect cell. Update that static cell reference by using a Named range. From the ribbon under the Formulas tab>Defined Names group>Name Manager (Hotkey: Ctrl+F3) to display the Name Manager dialog.

enter image description here

In the Name Manager dialog click the New button to create a named range for this cell. Under Scope choose the sheet it belongs to so it's limited to just that sheet and refer to the cell you want. Providing a descriptive name like YearCell will aid in understanding why it's has a name. Update your code to use presetSheet.Names("YearCell").RefersToRange.Value2. Now when, not if, a row/column is added your cell reference won't break. The same goes for the cells that refer to the variables shortName as well as the cells that contain the month's name.


Similar to how cell references are fragile your use of the Worksheet.Name property is also fragile. If the sheet names are changed then your code will break. Prefer using the Worksheet.CodeName property as it can only be changed in the IDE. Do this by going to the Project Explorer and double clicking on the sheet you want to update the CodeName for. From the menu at the top of the IDE View>Properties Window (Hotkey: F4) and where it says (Name) Sheet1 rename it to what you want. Naming it fooSheet allows you to use fooSheet.Name to get the name property or any other member of a worksheet object making your code less prone to easy breakage.


Your Const values that deal with months feel like they should be an Enum. This way when you need to use them you can type Months. (note the period) and you'll be given a full list of month names.

Public Enum Months
    NotSet
    January
    February
'   ...
    November
    December
End Enum

After converting to an Enum you can use a class module instead of a function. The class below uses a reference set from the menu at the top Tools>References>Microsoft Scripting Runtime which provides access to a dictionary Scripting.Dictionary. When the class is first initialized it populates the dictionaries thereafter allowing you to convert the supplied value instead of checking against every month.

The converter includes guard clauses to raise an error on invalid inputs. These can easily be modified as required.

Option Explicit

Private StringForEnum As Scripting.Dictionary
Private EnumForString As Scripting.Dictionary

Private Sub Class_Initialize()
    PopulateDictionaries
End Sub

Private Sub PopulateDictionaries()
    Set EnumForString = New Scripting.Dictionary
    Set StringForEnum = New Scripting.Dictionary

    EnumForString.CompareMode = VBA.VbCompareMethod.vbTextCompare
    EnumForString.Add vbNullString, Months.NotSet
    EnumForString.Add "Januar", Months.January
    EnumForString.Add "Februar", Months.February
    EnumForString.Add "März", Months.March
    EnumForString.Add "April", Months.April
    EnumForString.Add "Mai", Months.May
    EnumForString.Add "Juni", Months.June
    EnumForString.Add "Juli", Months.July
    EnumForString.Add "August", Months.August
    EnumForString.Add "September", Months.September
    EnumForString.Add "Oktober", Months.October
    EnumForString.Add "November", Months.November
    EnumForString.Add "Dezember", Months.December

    EnumForString.CompareMode = VBA.VbCompareMethod.vbTextCompare
    Dim i As Variant
    For Each i In EnumForString.Keys
        StringForEnum.Add EnumForString.Item(i), i
    Next
End Sub

Public Function ToEnum(ByVal value As String) As Months
    If Not EnumForString.Exists(value) Then
        ThrowInvalidArgument "ToEnum", value
    End If

    ToEnum = EnumForString(value)
End Function

Public Function ToString(ByVal value As Months) As String
    If Not StringForEnum.Exists(value) Then
        ThrowInvalidArgument "ToString", CStr(value)
    End If

    ToString = StringForEnum(value)
End Function

Private Sub ThrowInvalidArgument(ByVal source As String, ByVal value As String)
    Err.Raise 5, Information.TypeName(Me) & "." & source, "Invalid input '" & value & "' was supplied."
End Sub

Public Property Get Enums() As Variant
    Enums = EnumForString.Items
End Property

Public Property Get Strings() As Variant
    Strings = EnumForString.Keys
End Property

The converter is created and used as shown below. As shown it will return a value af 1

Dim converter As MonthConverter
Set converter = New MonthConverter
Debug.Print converter.ToEnum("Januar")

Your original function returned a two digit string number. Achieve that by wrapping the return value with the Format member of the Strings class: Strings.Format(converter.ToEnum("Januar")).

| improve this answer | |
\$\endgroup\$
6
\$\begingroup\$

FetchMonthNumber

Get is a standard across most programming languages, where as, Fetch is a standard when playing with a dog. But neither GetMonthNumber or FetchMonthNumber provide any context to the return value of the function.

 FetchMonthNumber = ""

The code above is unnecessary. FetchMonthNumber is typed as a string and has a default value of "".

If monthName = January Then
    FetchMonthNumber = "01"
    Exit Function
End If
If monthName = February Then
    FetchMonthNumber = "02"
    Exit Function
End If
If monthName = March Then
    FetchMonthNumber = "03"
    Exit Function
End If

Multiple If statements, in which, only one statement will trigger should be combined.

If MonthName = January Then
    FetchMonthNumber = "01"
ElseIf MonthName = February Then
    FetchMonthNumber = "02"
ElseIf MonthName = March Then
    FetchMonthNumber = "03"

Consider using a Select Case when every case is triggered based on different variations of a value

Select Case MonthName
Case January
    FetchMonthNumber = "01"
Case February
    FetchMonthNumber = "02"
    Exit Function
Case March
    FetchMonthNumber = "03"

Returning the Month number as long and using Format(MonthNumber,"##") will make it easier to change the formats.

SaveAsPdf()

Set presetSheet = ActiveWorkbook.Sheets(1)

ActiveWorkbook is best used in special situations when working with multiple workbooks. Using ThisWorkbook ensures that the code will always reference the workbook that contains the code.

Sheets(1) assumes that the project setup will never change. Referring to worksheets by their code names will make the code more robust. Renaming the worksheets will make the code easier to read.

Dim shell As Object
Set shell = CreateObject("WScript.Shell")

fileName = shell.SpecialFolders("MyDocuments") + "\" + shortName + ".pdf"

Not a best practice but I wouldn't both with the shell helper variable. You are not reusing it or testing where or not it is instantiated.

fileName = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") + "\" + shortName + ".pdf"

Alternately, you could use Environ to return the user directory.

fileName = Environ("USERPROFILE") & "Documents\" + shortName + ".pdf"

But why force users to save their files in a specific directory. Consider setting the InitialFilename of the Application.FileDialog(msoFileDialogSaveAs) or Application.GetSaveAsFilename() and allowing the user to specify the file location.

Better yet, I would use the Application.FileDialog(msoFileDialogFolderPicker) to save the file location on the presets worksheet. I would then create a root directory ( e.g. Company PDFs) and subdirectories to file the pdfs by year.

Considering that the files are to be sent by emails and that they are basically time-sensitive signed documents, it may just be best to dump them in the Environ("Temp") where they will be cleaned up during system maintenance.

ComposeFileName

Dim year As String

The code above changes all instances of Year to year. Because, for some odd reason, the VBA will rename variables, subs or functions that share a name to match the case of the last declaration of that name. I prefer to use Of to suffix all my date variables (e.g. YearOf, MonthOf, WeekOf, DateOf ...)/

Passing the worksheet as a parameter to ComposeFileName will make the code more versatile. For instance, you decided to add a listbox to the preset sheet send multiple emails based on its selections. Currently you would have to rewrite this subroutine but passing in the worksheet opens up a lot of possibilities.

If sheetName = PreSetting Then
    ComposeFileName = Year + "_" + sheetName + "_" + shortName
    Exit Function
End If
If sheetName = Expenses Then
    ComposeFileName = Mid(Year, 3) + "-" + FetchMonthNumber(ActiveSheet.Cells(4, 3).Value) + "_" + ExpensesName + "_" + shortName
    Exit Function
End If
If sheetName = VacationApplication Then
    ComposeFileName = Year + "_" + VacationApplicationName + "_(" + Format(Date) + ")_" + shortName
    Exit Function
End If

Here is another instance where using a Select Case statement is easier to read and modify than multiple If statements.

Remove the Exit Function clauses. Not only do they clutter up the screen but they make it harder to modify the code.

ComposeFileName = Year + "_" + VacationApplicationName + "_(" + Format(Date) + ")_" + shortName

The default format for Format(Date) is MM/DD/YYYY. Forward slashes(/) are not permitted in filenames. Here are some valid replacement options: MMDDYYYY, MM.DD.YYYY or MM-DD-YYYY.

As IvenBach mentioned, using named ranges and worksheet codenames will make your code easier to read and modify.

Use + to concatenate strings can lead to type mismatch errors and unexpected results. Use & instead.

enter image description here

Store Dates as Numbers

I'm not sure of the project setup but is in generally better to store dates as numbers and format their values as needed. Consider that the preset tab has a cell for the Year and one for the Month name. It may make more sense to use have the date in one cell and have to other cell reference the first. The number format for the Year would be "YYYY" and for the Month would be "[$-de-DE] MMMM".
Prefixing the number format with [$-de-DE] tells Excel to display the value in German. The codes on this page: Get All Language-Country Code List for all Culture in C#, ASP.Net can be used with some modifications. The actual CultureInfo code is de-DE. [$de-DE] will prefix the display value with de to specify the German format. Adding a dash [$-de-DE] will remove the prefix. These number formats can also be used by the WorksheetFunction.Text().

enter image description here

Refactored Code

Here is a rough rewrite using most of my suggestions:

Sub SaveAsPdf()
    Dim TargetWorksheet As Worksheet
    Set TargetWorksheet = ActiveSheet

    Dim shortName As String
    shortName = GetPDFFileName(TargetWorksheet)

    Dim fileName As String
    fileName = Environ("USERPROFILE") & "Documents\" & shortName & ".pdf"

    TargetWorksheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

    SendAsMail fileName, StaffEmailAdress, shortName

End Sub

Private Function GetPDFFileName(ByVal TargetWorksheet As Worksheet) As String

    Dim YearOf As Long
    YearOf = TargetWorksheet.Range("Year").Value

    Dim shortName As String
    shortName = presetSheet.Cells(3, 11).Value

    Dim Result As String

    Select Case TargetWorksheet.Name
    Case wsPreSetting.Name

        Result = YearOf & "_" & sheetName & "_" & shortName

    Case wsExpenses.Name

        Dim MonthOf As Long
        MonthOf = GermanMonthToNumber(TargetWorksheet.Range("Month").Value)
        Result = Mid(Year, 3) & "-" & Format(MonthOf, "##") & "_" & ExpensesName & "_" & shortName

    Case wsVacationApplication.Name

        GetPDFFileName = Year & "_" & VacationApplicationName & "_(" & Format(Date, "MMDDYY") & ")_" & shortName

    End Select

    GetPDFFileName = Result

End Function

Private Function GermanMonthToNumber(monthName As String) As Long
    Select Case monthName
        Case January
            GermanMonthToNumber = 1
        Case February
            GermanMonthToNumber = 2
        Case March
            GermanMonthToNumber = 3
        Case April
            GermanMonthToNumber = 4
        Case May
            GermanMonthToNumber = 5
        Case June
            GermanMonthToNumber = 6
        Case July
            GermanMonthToNumber = 7
        Case August
            GermanMonthToNumber = 8
        Case September
            GermanMonthToNumber = 9
        Case October
            GermanMonthToNumber = 10
        Case November
            GermanMonthToNumber = 11
        Case December
            GermanMonthToNumber = 12
    End Select

End Function
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ When using Application.WorksheetFunction.Text(2,"[$-en-US] mmmm") I always get January as a result. Trying any other region language results in the region appropriate string for January, irregardless of the numeric argument provided. Testing as a function on a worksheet produces the same result. Am I missing something apparent to get this working properly? :+1: as I didn't know region codes could be used. \$\endgroup\$ – IvenBach Dec 27 '19 at 18:43
  • 1
    \$\begingroup\$ @IvenBach WorksheetFunction.Text() is expecting a date because we're passing mmm as a format option. 2 is being evaluated as Day 2 of the Excel calendar. The result of WorksheetFunction.Text(2,"mm/dd/yyyy") is #01/02/1900#. \$\endgroup\$ – TinMan Dec 27 '19 at 19:07
  • \$\begingroup\$ Excellent explanation. Useful tips. \$\endgroup\$ – Ricardo Diaz Dec 28 '19 at 1:05
3
\$\begingroup\$

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 = "StaffEmail@Company.org"

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.

| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ There are some good ideas in here, but IMO this is over-abstracted: if IPathAndName implementations were just different instances of the same class, then there wouldn't be any code duplication. The abstractions are good, just not at a level that feels right all the time. Note that having two parallel arrays is usually considered a code smell: needs a better data structure (like a keyed collection?) \$\endgroup\$ – Mathieu Guindon Dec 29 '19 at 2:54
  • \$\begingroup\$ I need to mention that this isn't how I showed factory methods though. Self is a Property Get that takes no parameters and does nothing more than return a reference to the current instance: turning that into a side-effecting Function that mutates the current instance and then returns itself, makes a rather mind-bending runtime context to keep in mind ("which instance am I mutating?") when reading that code... and then because of the side-effects, you had to add code to prevent mutating the default instance - and it shouldn't be needed. \$\endgroup\$ – Mathieu Guindon Dec 29 '19 at 3:04
  • \$\begingroup\$ @MathieuGuindon. You are right to observe that things are a bit over extracted. I was just trying to demonstrate an alternative approach which recognised that potentially four different activities had been crammed into a single function. I used dual arrays as input because VBA doesn't allow initialisation at the time of creation. Likewise, code to differentiate between the base instance and other instances should be a must once you have set the PredecalredId of a Class to True. because VBA won't do it for you. \$\endgroup\$ – Freeflow Dec 29 '19 at 6:47
1
\$\begingroup\$

Your original code is simple and straightforward, easy to follow. There are a couple things that might trip you up when maintaining the code and that I would suggest could change.

  • You have a solid list of Private Const declarations at the top of your code. Abstracting the strings into consts is very good practice, but eventually you'll find that it's even better to work around the need for as many of the consts as possible. In this regard, I'll repeat the suggestion from IvenBach that you create worksheet code names in the IDE.

So for my example below, you could rename the worksheets in the IDE manually by editing the Worksheet Properties (Name) field, or by running this short sub (after modifying it as needed):

Private Sub RunOnceToChangeCodeNames()
    '--- you can delete this sub after you run it
    ThisWorkbook.VBProject.VBComponents("Voreinstellungen").Name = "PresetsWS"
    ThisWorkbook.VBProject.VBComponents("Urlaubsantrag").Name = "VacationWS"
    ThisWorkbook.VBProject.VBComponents("Spesen").Name = "ExpensesWS"
End Sub

Now you can directly refer to any of these worksheets by its code name directly, as in

Debug.Print PresetsWS.Name
  • I'll urge you to be a bit clearer in your variable naming. As an example, you use shortName for the part of the file name in a folder. But I could also interpret shortName to mean it's the shortened name of a person as in "Wolf" for "Wolfgang". So in my example you'll see shortName changed to shortFilename and other similar changes.

  • For the refactoring of the ComposeFileName function, there are several points.

    1. This is the only code that uses three of the Consts defined above. So I reccommend restricting the scope of these to this function only.
    2. Change the input parameter to be the currently active worksheet, and pass it as a reference (ByRef). Passing the PresetsWS is meaningless because it never changes, whereas the currently active worksheet is significant.
    3. Change the several If statements to a Select Case block. The reason is you'll save from using multiple Exit Function points. Whether or not that's a good or bad thing is debatable, but I believe in this situation it makes the code cleaner.
    4. Notice also that I've pulled the MonthNumber call out of the statement building the string. This is so I can use Format on the month number to create exactly what I want. I could have built this into the MonthNumber function, but that would make it less flexible if I wanted to use it in the future.

So here's the ComposeShortFilname function:

Private Function ComposeShortFilname(ByRef thisWS As Worksheet) As String
    Private Const VacationApplicationName As String = "Urlaub_Gleittag_Antrag"
    Private Const ExpensesName As String = "Reisekosten"
    Private Const WorkingTime As String = "Arbeitszeit"

    Dim year As String
    year = PresetsWS.Cells(2, 11).Value

    Dim shortName As String
    shortName = PresetsWS.Cells(3, 11).Value

    Dim month As Long
    Select Case thisWS.CodeName
        Case PresetsWS.CodeName
            ComposeFileName = year & "_" & thisWS.CodeName & "_" & shortName

        Case ExpensesWS.CodeName
            month = MonthNumber(thisWS.Cells(4, 3).Value)
            ComposeFileName = Mid(year, 3) & "-" & _
                                           Format(month, "0#") & _
                                           "_" & ExpensesName & "_" & shortName

        Case VacationWS.CodeName
            ComposeFileName = year & "_" & VacationApplicationName & _
                              "_(" & Format(Date, "mm-dd-yyyy") & ")_" & shortName

        Case Else
            month = MonthNumber(thisWS.Name)
            ComposeFileName = Mid$(year, 3) & "-" & _
                                           Format(month, "0#") & "_" & _
                                           WorkingTime & "_" & shortName
    End Select
End Function
  • I agree with others that your FetchMonthNumber routine is ripe for refactoring. However, I believe it can be greatly simplified using Siddarth's valuable answer here.

So the routine collapses to

Private Function MonthNumber(ByVal monthName As String) As Long
    MonthNumber = Month(DateValue("01 " & monthName & " 2019"))
End Function

Notice that the function relies on the application setting for the country code. As your settings should all be using German, then the month name should be interpreted correctly. Also, I believe that the "Fetch" part of the function name is redundant and can be shortened to simply MonthNumber. (Note that the year in the code statement above really doesn't matter at all.)

  • Lastly, concatenate your strings with an ampersand "&" and don't use a plus sign "+". For reasons.

So here is the whole module is a single block:

Option Explicit

Private Sub RunOnceToChangeCodeNames()
    '--- you can delete this sub after you run it
    ThisWorkbook.VBProject.VBComponents("Voreinstellungen").Name = "PresetsWS"
    ThisWorkbook.VBProject.VBComponents("Urlaubsantrag").Name = "VacationWS"
    ThisWorkbook.VBProject.VBComponents("Spesen").Name = "ExpensesWS"
End Sub

Sub SaveAsPdf()
    Private Const StaffEmailAdress = "StaffEmail@Company.org"
    Dim shortFilename As String
    shortFilename = ComposeShortFilename(ActiveSheet)

    Dim shell As Object
    Set shell = CreateObject("WScript.Shell")

    Dim fileName As String
    fileName = shell.SpecialFolders("MyDocuments") & "\" & shortName & ".pdf"

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    fileName:=fileName, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False

    SendAsMail fileName, StaffEmailAdress, shortFilename
End Sub

Private Sub SendAsMail(fileName As String, receiver As String, 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 = ""
        .subject = subject
        .Attachments.Add fileName
    End With
End Sub

Private Function ComposeShortFilname(ByRef thisWS As Worksheet) As String
    Private Const VacationApplicationName As String = "Urlaub_Gleittag_Antrag"
    Private Const ExpensesName As String = "Reisekosten"
    Private Const WorkingTime As String = "Arbeitszeit"

    Dim year As String
    year = PresetsWS.Cells(2, 11).Value

    Dim shortName As String
    shortName = PresetsWS.Cells(3, 11).Value

    Dim month As Long
    Select Case thisWS.CodeName
        Case PresetsWS.CodeName
            ComposeFileName = year & "_" & thisWS.CodeName & "_" & shortName

        Case ExpensesWS.CodeName
            month = MonthNumber(thisWS.Cells(4, 3).Value)
            ComposeFileName = Mid(year, 3) & "-" & _
                                           Format(month, "0#") & _
                                           "_" & ExpensesName & "_" & shortName

        Case VacationWS.CodeName
            ComposeFileName = year & "_" & VacationApplicationName & _
                              "_(" & Format(Date, "mm-dd-yyyy") & ")_" & shortName

        Case Else
            month = MonthNumber(thisWS.Name)
            ComposeFileName = Mid$(year, 3) & "-" & _
                                           Format(month, "0#") & "_" & _
                                           WorkingTime & "_" & shortName
    End Select
End Function

Private Function MonthNumber(ByVal monthName As String) As Long
    MonthNumber = month(DateValue("01 " & monthName & " 2019"))
End Function
| improve this answer | |
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.