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.
[/FONT][/COLOR]
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="][FONT="]" & 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