Consulting

Results 1 to 2 of 2

Thread: Email attachments without user intervention

  1. #1
    VBAX Newbie
    Joined
    Nov 2021
    Posts
    1
    Location

    Email attachments without user intervention

    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
    Last edited by Fyldeboy; 11-17-2021 at 06:13 AM.

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •