VBA - Save File With Naming Convention & Create Folder & Attach File to Custom Message Email (Current code Mostly Works)

[Armygeddan]

Hello,


I am attempting to utilize a Code that will auto save a file to a custom destination where it creates the folders for me (this part of the code works)


I am having the issue of saving the file and attaching it to an email.
I want to name the File AND have that File Name in the subject line of the email.
The main File Name is based off of Range Name in the Excel File named "AcquisitionTitle"


I don't want to send this email but generate a preview message where all the user has to do is click send after checking the message.


Below is my current code

Private Sub SaveAndEmailAcquisition()


    Dim OutApp      As Object
    
    Dim OutMail     As Object
    Dim StrBody     As String
    Dim StrTo       As String
    Dim StrSubject  As String
    Dim StrAtt      As String
    Dim strGenericFilePath          As String: strGenericFilePath = "V:\Info Security\info security\Procurement\"
    Dim strYearSlash                As String: strYearSlash = Year(Date) & "\"
    Dim strMonthSlash               As String: strMonthSlash = CStr(Format(DateAdd("M", -1, Date), "MM")) & "\"
    Dim strYearBracket              As String: strYearBracket = Year(Date) & "_"
    Dim strMonthBracket             As String: strMonthBracket = CStr(Format(DateAdd("M", -1, Date), "MM")) & "_"
    Dim strFileName                 As String: strFileName = Sheets("Acquisition").Range("AcquisitionTitle")


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' Check for year folder and create if needed
    
    If Len(Dir(strGenericFilePath & strYearSlash, vbDirectory)) = 0 Then
        MkDir strGenericFilePath & strYearSlash
    End If
    
    ' Check for month folder and create if needed
    
    If Len(Dir(strGenericFilePath & strYearSlash & strMonthSlash, vbDirectory)) = 0 Then
        MkDir strGenericFilePath & strYearSlash & strMonthSlash
    End If
    
    ' Saves as Excel
    
    ActiveWorkbook.SaveAs Filename:= _
    strGenericFilePath & strYearSlash & strMonthSlash & strYearBracket & strMonthBracket & strFileName
    
    ' Popup Message that the conversion and save is complete as YYYY_FileName
     
    MsgBox "File Saved As:" & vbNewLine & "\" & strYearBracket & strMonthBracket & strFileName
    
    ' Enter Subject here
    StrSubject = Sheets("Acquisition").Range("AcquisitionTitle")
    
    ' Enter content of Email here
    StrBody = "Please see attached File," & "<BR><BR><BR>" & vbNewLine & "List any additional details that I should know here that aren't listed on the form" & _
    "<br><br><br> Thanks,"
    
    ' Code that attaches the Document to the email
    StrAtt = ActiveDocument.FullName
    
    ' Who the email will be sent to
    StrTo = "INSERT EMAIL ADDRESS HERE"


    With OutMail
        .Display
        .To = StrTo
        .CC = ""
        .BCC = ""
        .Subject = StrSubject
        .HTMLBody = StrBody & .HTMLBody
        .Attachments.Add StrAtt
      ' .Send
    End With


    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing


    End Sub

 

[Norie]

What isn't working?

I don't see much wrong with the code, though .Display should probably be after the code to set the email up.

    With OutMail
        .To = StrTo
        .CC = ""
        .BCC = ""
        .Subject = StrSubject
        .HTMLBody = StrBody & .HTMLBody
        .Attachments.Add StrAtt
        .Display
    End With

 

[Armygeddan]

I figured out what the problem was, I had to change from

[COLOR=#333333]StrAtt = ActiveDocument.FullName[/COLOR]

to

[COLOR=#333333]StrAtt = ActiveWorkbook.FullName[/COLOR]

Was driving me crazy because the whole code looked good to me too but was still getting an error of missing an object.
Instead of saving just 1 sheet, I'm attempting to save the whole workbook.

Thanks for taking a look