Attach all files in folder not working fully

R

Ruca13

Board Regular
Joined
Oct 13, 2016
Messages
85
Hello experts,

I have a macro that creates an email, attaches two excel files and all the pdf files in a specified folder.

The macro does not return any errors, but there are certain pdf files that don't get attached.

Those files have in the name "‐". This is not a normal hyphen. When I use the code formula, it returns 63, not 45 as expected.

If I replace the symbol when saving the file, the files are attached.

Can someone please help me with this.

Please find below my code.

Code: 
    Option Explicit


Sub invoicereports()




    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False


Dim master As Workbook
Dim firstreport As Worksheet
Dim secreport As Worksheet
Dim lookups As Variant
Dim settings As Worksheet
Dim infomail As Variant
Dim invoicepath As Variant
Dim invoicepdf As Variant
Dim invoicenumber As Variant


Set master = ThisWorkbook
Set firstreport = master.Worksheets("1 Invoice report")
Set secreport = master.Worksheets("2 Invoice report")
Set lookups = master.Worksheets("Lookups")
Set settings = master.Worksheets("Settings")
invoicenumber = settings.Cells(18, 24)
infomail = settings.Cells(4, 19)


    master.Worksheets(1).Activate
    
    If ActiveSheet.AutoFilterMode Then
    ActiveSheet.AutoFilter.ShowAllData
    Else
    End If


lookups.Cells(1, 24).FormulaR1C1 = "=TODAY()"
Dim FName           As String
Dim FPath           As String
Dim filename As String
Dim filename2 As String
Dim NewBook         As Workbook
Dim clientname As Variant
clientname = "XXXX"
invoicepath = master.Worksheets("Settings").Cells(7, 15) & clientname & "\" & lookups.Cells(1, 28) & "\" & "Invoices\To Send\NEW\"
invoicepdf = Dir(invoicepath & "*.pdf")
   Application.Calculation = xlCalculationAutomatic
    FPath = master.Worksheets("Settings").Cells(7, 15) & clientname & "\" & lookups.Cells(1, 28) & "\" & lookups.Cells(1, 27).Text & " " & _
    lookups.Cells(1, 30) & " " & lookups.Cells(1, 28)
    
If Application.WorksheetFunction.CountA(firstreport.Columns(1)) > 2 Then
firstreport.Activate
    FName = format(lookups.Cells(1, 24), "ddmmyyyy") & " 1 Invoice Approval" & ".xlsx"
    
    filename = FPath & "\" & FName
    
    Set NewBook = Workbooks.Add


    firstreport.Copy Before:=NewBook.Sheets(1)
    NewBook.Sheets(2).Delete


    If Dir(filename) <> "" Then
        MsgBox "File " & filename & " already exists"
        NewBook.Close savechanges:=False
    Else
        NewBook.SaveAs filename:=filename
        NewBook.Close
    End If
Else
End If


If Application.WorksheetFunction.CountA(secreport.Columns(1)) > 2 Then


secreport.Activate
    FName = format(lookups.Cells(1, 24), "ddmmyyyy") & " 2 Invoice Approval" & ".xlsx"
    
    filename2 = FPath & "\" & FName
    
    Set NewBook = Workbooks.Add


    secreport.Copy Before:=NewBook.Sheets(1)
    NewBook.Sheets(2).Delete


    If Dir(filename2) <> "" Then
        MsgBox "File " & filename2 & " already exists"
        NewBook.Close savechanges:=False
    Else
        NewBook.SaveAs filename:=filename2
        NewBook.Close
    End If
Else
End If
   Application.Calculation = xlCalculationManual
master.Worksheets(1).Activate
    
    ActiveSheet.Range(Cells(2, 1), Cells(Cells(2, 1).End(xlDown).Row, Cells(2, 1).End(xlToRight).Column)).AutoFilter Field:=32, Criteria1:= _
        xlFilterThisWeek, Operator:=xlFilterDynamic


    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim excel_body As Range
    Dim invoiceexcelbody As Range
            
    'Select cells that are to be sent, add temp sheet to rearrange info
    Set excel_body = Range(Cells(2, 1), Cells(Cells(2, 1).End(xlDown).Row, 20)).SpecialCells(xlCellTypeVisible)
    Set invoiceexcelbody = Range(Cells(2, invoicenumber), Cells(2, invoicenumber).End(xlDown)).SpecialCells(xlCellTypeVisible)


    excel_body.Select
    Selection.Copy
    
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Cells(1, 1).PasteSpecial Paste:=xlValues
    ActiveSheet.Cells(1, 1).PasteSpecial Paste:=xlFormats


    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells(1, 1).Select
    Application.CutCopyMode = False
    ActiveSheet.Name = "Flight Schedule"
    Set excel_body = Range(Cells(1, 1), Cells(Cells(1, 1).End(xlDown).Row, Cells(1, 1).End(xlToRight).Column))




    ActiveSheet.Previous.Select
    TempFileName = format(lookups.Cells(1, 24), "ddmmyyyy") & " Invoice Approval"


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Dim mail_body_message As String
    Dim mailfontname As String
    Dim mailfontsize As String
    Dim mailfontcolor As String
    
    mailfontname = settings.Cells(9, 15).Value
    mailfontsize = settings.Cells(10, 15).Value
    mailfontcolor = settings.Cells(11, 15).Value
    
    mail_body_message = "Dear xxx," & "
" & "
" & "Please find attached the report and the PDF format invoices:"
    
    On Error Resume Next
    With OutMail
            Set .SendUsingAccount = OutApp.Session.Accounts.Item(infomail)
            .Display
            .To = "xxxx@xxxx.com"
            .CC = ""
            .BCC = ""
            .attachments.Add (filename)
            .attachments.Add (filename2)
            
            invoicepath = master.Worksheets("Settings").Cells(7, 15) & clientname & "\" & lookups.Cells(1, 28) & "\" & "Invoices\To Send\NEW\"
            invoicepdf = Dir(invoicepath & "*.pdf")


            Do While Len(invoicepdf) > 0
            .attachments.Add invoicepath & invoicepdf
            invoicepdf = Dir()
            Loop
            
            .Subject = TempFileName
            .htmlbody = "[COLOR=&quot][FONT=&quot]" & mail_body_message & RangetoHTML(excel_body) & .htmlbody & "
"
                .Display
             '   .Send
        End With


    Set OutMail = Nothing
    Set OutApp = Nothing


Worksheets("Flight Schedule").Delete


Worksheets(1).Activate


    If ActiveSheet.AutoFilterMode Then
    ActiveSheet.AutoFilter.ShowAllData
    Else
    End If
    
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Comparison"
    
    invoiceexcelbody.Copy
    
    ActiveSheet.Cells(1, 2).PasteSpecial xlPasteValues
    
    firstreport.Columns(6).Copy
    
    ActiveSheet.Cells(1, 3).PasteSpecial xlPasteValues
    
    Range(Cells(2, 3), Cells(2, 3).End(xlDown)).Select
    ActiveSheet.Range(Cells(2, 3), Cells(2, 3).End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Cells(2, 3), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range(Cells(2, 3), Cells(2, 3).End(xlDown))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Columns(3).Select
    Dim findunique As Range
    Set findunique = Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)


    If findunique Is Nothing Then
    'do something
    Else
    findunique.Select
    Selection.Delete Shift:=xlUp
    End If
    
    secreport.Columns(6).Copy
    
    ActiveSheet.Cells(1, 4).PasteSpecial xlPasteValues
    
    Range(Cells(2, 4), Cells(2, 4).End(xlDown)).Select
    ActiveSheet.Range(Cells(2, 4), Cells(2, 4).End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Cells(2, 4), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range(Cells(2, 4), Cells(2, 4).End(xlDown))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Columns(4).Select
    Set findunique = Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)


    If findunique Is Nothing Then
    'do something
    Else
    findunique.Select
    Selection.Delete Shift:=xlUp
    End If
    
    Range(Cells(2, 4), Cells(2, 4).End(xlDown)).Select
    Selection.Copy
    Cells(Cells(2, 3).End(xlDown).Row + 1, 3).Select
    Selection.PasteSpecial xlPasteValues
    
    Columns(4).Clear
    
    Cells(1, 3) = "Reports"
    
    Range(Cells(2, 3), Cells(2, 3).End(xlDown)).Select
    ActiveSheet.Range(Cells(2, 3), Cells(2, 3).End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Cells(2, 3), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range(Cells(2, 3), Cells(2, 3).End(xlDown))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
    Columns(2).Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(2, 2).End(xlDown)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range(Cells(2, 2), Cells(2, 2).End(xlDown))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns(3).Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, 3), Cells(2, 3).End(xlDown)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range(Cells(2, 3), Cells(2, 3).End(xlDown))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
Dim varDirectory As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String


strDirectory = master.Worksheets("Settings").Cells(7, 15) & clientname & "\" & lookups.Cells(1, 28) & "\" & "Invoices\To Send\NEW\"


i = 1
flag = True
varDirectory = Dir(strDirectory, vbNormal)


While flag = True
If varDirectory = "" Then
flag = False
Else
Worksheets("Comparison").Cells(i + 1, 1) = varDirectory
'Cells(i + 1, 2) = strDirectory + varDirectory
'returns the next file or directory in the path
varDirectory = Dir
i = i + 1
End If
Wend


 Columns(1).Select
    
    Selection.Replace What:=".pdf", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:=".pdf", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        
        
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(2, 1).End(xlDown)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range(Cells(2, 1), Cells(2, 1).End(xlDown))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
Cells(1, 1).Select
Cells(1, 1) = "Attachments"
    
Range(Columns(1), Columns(3)).AutoFit
        
    
    'first column = attachments from the email
    'second columnn is the schedule in the email body
    'thir column is the invoice numbers from the reports


    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True


End Sub
Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "\" & format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    'Copy the range and create a new workbook to past the data in
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAll, , False, False
        '.Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Range(Columns(1), Columns(20)).font.Size = 9
        .Range(Columns(1), Columns(20)).EntireColumn.AutoFit
            With Range(Columns(1), Columns(20)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
            End With
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With


    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
[/FONT][/COLOR]
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
Thank you Odin,

you insights were helpful.

I was not able to solve it yet. What I could do was on our workbook, everytime we introduce information having the unrecognized character, it replaces it for a regular hyphen.

Replacing it in filenames is something I was not able to figure out so far.

I was trying this:
Code: 
    Do While Len(invoicepath) > 0
        strchr = Mid(invoicepdf, n, 1)
            If AscW(strchr) > 255 Then
            invoicepdf = Replace(invoicepdf, strchr, "-")
            End If


    invoicepdf = Dir()
    Loop

But I get an invalid procedure error on the strchr line. It probably only works in strings inside the workbook, not filenames.

If you have any other insights, I would appreciate.

If not, it was already great to understand why it was failing.
 
Upvote 0
You must log in or register to reply here.

Similar threads

larinda4
  • Question
VBA: Send Outlook Email & Attach PDF
Replies
1
Views
130
Trebor76
T
C
  • Solved
VBA attach PDF to email stopped working
Replies
8
Views
674
FormR
FormR
M
  • Question
Excel VBA Save PDF within workbook folder and send as email attachment
Replies
1
Views
224
rpaulson
rpaulson
The Ruff Report
  • Question
Add multiple attachments from email list
Replies
1
Views
278
Trebor76
T
C
  • Question
VBA - Email specific range and attach Sheet1
Replies
4
Views
492
Clermont
C

Forum statistics

Threads
1,214,863
Messages
6,121,978
Members
449,058
Latest member
oculus

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top