Email attachments without user intervention

[Fyldeboy]

VBA noob (apart from editing a few existing macros) so if I'm asking too much, tell me . . .

• I have a series of xlsx files in folder 'refunds'
• Need to produce pdfs of these (single page - UK A4 size)*
• Attach all to email and send at set time (twice a week), ideally with list of attached files.
• Move all files from 'refunds' to 'complete', ideally renamed with a filename prefix/suffix 'refunded (date)'

All without any user intervention at all.

*I may be able to negotiate sending the xlxs without converting to pdf.

Using office 2016 on Windows 10

[gmayor]

See https://www.slipstick.com/developer/...cros-schedule/ and use that process to run the following macro as required:

Option Explicit

Sub SendPDFs()
'Graham Mayor - https://www.gmayor.com - Last updated - 18 Nov 2021
Const sPath As String = "C:\Refunds\"
Const sMove As String = "C:\Complete\"
Const sTo As String = "someone@somewhere.com"
Const sMessage As String = "Please see the attached files:"
Dim sTempPath As String: sTempPath = Environ("Temp") & "\"
Dim xlApp As Object
Dim xlWB As Object
Dim strFile As String, sPDF As String
Dim sNewName As String, sOldName As String
Dim olItem As MailItem
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim i As Long
    Set olItem = CreateItem(olMailItem)
    With olItem
        .To = sTo
        .Subject = "Attached worksheets"
        .BodyFormat = olFormatHTML
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range(0, 0)
        .Display
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        xlApp.Visible = True
        i = 0
        strFile = Dir$(sPath & "*.xlsx")
        Do While strFile <> ""
            i = i + 1
            If i = 1 Then Exit Do
            strFile = Dir$()
        Loop
        If i = 0 Then
            oRng.Text = "No files processed"
            '.Send 'restore after testing
            GoTo lbl_Exit
        End If
        oRng.Text = sMessage & vbCr
        oRng.collapse 0
        strFile = Dir$(sPath & "*.xlsx")
        While strFile <> ""
            sOldName = sPath & strFile
            Set xlWB = xlApp.Workbooks.Open(sOldName)
            sPDF = Replace(strFile, "xlsx", "pdf")
            xlWB.Sheets(1).ExportAsFixedFormat Type:=0, _
                                               FileName:=sTempPath & sPDF, _
                                               Quality:=0, _
                                               IncludeDocProperties:=True, _
                                               IgnorePrintAreas:=False, _
                                               OpenAfterPublish:=False
            xlWB.Close SaveChanges:=False
            .Attachments.Add sTempPath & sPDF
            oRng.Text = sPDF & vbCr
            oRng.collapse 0
            Kill sTempPath & sPDF
            sNewName = FileNameUnique(sMove, strFile, "xlsx")
            Name sOldName As sMove & sNewName
            strFile = Dir$()
        Wend
        '.Send 'restore after testing
    End With
lbl_Exit:
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set olItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function