VBA Email not working

[JoeyGaspard]

I am guessing an update to excel has broken this process, I have several spreadsheets with this code to email an array of sheets, and as of this week, when i try to run any of them, I get this error:

This is the code I have been using: When I run the the code 1 line at a time, it fails on the text in YELLOW. Any help would be greatly appreciated! TIA!


Sub Mail_Sheets_ArrayMV()


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 OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set Sourcewb = ActiveWorkbook


'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("NOCSTx", "NOCSNOLA", "KCCS", "GSCS", "GeorgiaPF", "USCOLD", "NOCSHC")).Copy
End With


'Close temporary Window
TempWindow.Close


Set Destwb = ActiveWorkbook


'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
End With


' 'Change all cells in the worksheets to values if you want
' 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


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Freezer Inventory -- " & Format(Now, "mm-dd-yyyy")


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 = "emails here"
.CC = ""
.BCC = ""
.Subject = "Freezer Inventory"
.Body = "Here is the Freezer Inventory for your Review"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With


'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr


Set OutMail = Nothing
Set OutApp = Nothing


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Richard U]

Sometimes Excel gets corrupted and you can get errors even though the code is fine.

First, try copying your code into either notepad or notepad ++ Plain text is important!

Then:

1. delete the module.
2. Add a new module.
3. Copy your code from the text file into the new module

Then, go to Tools=>References and make sure the Office 16 object library and Microstof acviex Data object boxes are checked

Hope this helps

 

[JoeyGaspard]

Sometimes Excel gets corrupted and you can get errors even though the code is fine.

First, try copying your code into either notepad or notepad ++ Plain text is important!

Then:

1. delete the module.
2. Add a new module.
3. Copy your code from the text file into the new module

Then, go to Tools=>References and make sure the Office 16 object library and Microstof acviex Data object boxes are checked

View attachment 31734


Hope this helps

Thank you for the help, but it did not work.

 

[Richard U]

Thank you for the help, but it did not work.

Did you change Versions of excel?

 

[JoeyGaspard]

Did you change Versions of excel?

No, but we use Office 365 and get the updates that comes with it??