Hello all, I have a workbook and would like to email a specific sheet in the workbook as an attachment. I've been using the code found on https://www.rondebruin.nl/ for years and it works well! I recently added a table on the worksheet i intend to email out and now the VBA keeps erroring out. not sure why a table would affect it it and i cant seem to figure it out. Can someone please take a look to see if anything is off on this code.
I ran a debug and it errors out on the part of the code that is highligthed in red. Could it be the name of the table? or name of the sheet?
MUCH MUCH appreciated!
ub DailyEmail()
If MsgBox("Send Email?", vbYesNo) = vbNo Then Exit Sub
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim i As Long
today = Int(Now())
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("Report")).Copy
End With
TempWindow.Close
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
TempFilePath = Environ$("temp") & ""
TempFileName = "" & GetWB_Name_No_Ext(Sourcewb) & " " _
Sheets("Report").Select
Columns("L:N").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Shapes("Rectangle 1").Delete
Sheets("report").Select
Rows("3:3").Select
Selection.Delete Shift:=xlUp
Columns("L:W").Select
Selection.Delete Shift:=xlToLeft
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
' .To = ""
' .CC = ""
.BCC = ""
.Subject = "report as of " + Application.Text(today, "MM-DD-YY") + ""
.body
.Attachments.Add Destwb.FullName
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function GetWB_Name_No_Ext(wb As Workbook) As String
Dim vParts As Variant
vParts = Split(wb.Name, ".")
ReDim Preserve vParts(UBound(vParts) - 1)
GetWB_Name_No_Ext = Join(vParts)
End Function
I ran a debug and it errors out on the part of the code that is highligthed in red. Could it be the name of the table? or name of the sheet?
MUCH MUCH appreciated!
ub DailyEmail()
If MsgBox("Send Email?", vbYesNo) = vbNo Then Exit Sub
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Dim i As Long
today = Int(Now())
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("Report")).Copy
End With
TempWindow.Close
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next sh
TempFilePath = Environ$("temp") & ""
TempFileName = "" & GetWB_Name_No_Ext(Sourcewb) & " " _
Sheets("Report").Select
Columns("L:N").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Shapes("Rectangle 1").Delete
Sheets("report").Select
Rows("3:3").Select
Selection.Delete Shift:=xlUp
Columns("L:W").Select
Selection.Delete Shift:=xlToLeft
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
' .To = ""
' .CC = ""
.BCC = ""
.Subject = "report as of " + Application.Text(today, "MM-DD-YY") + ""
.body
.Attachments.Add Destwb.FullName
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function GetWB_Name_No_Ext(wb As Workbook) As String
Dim vParts As Variant
vParts = Split(wb.Name, ".")
ReDim Preserve vParts(UBound(vParts) - 1)
GetWB_Name_No_Ext = Join(vParts)
End Function