mikenelena
Board Regular
- Joined
- Mar 5, 2018
- Messages
- 139
- Office Version
- 365
- Platform
- Windows
Here is the code that I've gathered together for this. As the subject mentions, the code is placing an extra file extension on the names of Outlook attachments. The files still open, but it looks silly and I'd like to correct it. Can anyone tell me which lines need to be changed/added to correct this?
Much appreciated, thanks!
Much appreciated, thanks!
Code:
Sub SendWorkSheet()
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.Name '& Format (Now, "dd-mmm-yy")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
emailbody = "****** style=font-size:11pt;font-family:Calibri>My mileage report is attached.</BODY>"
With OutlookMail
.display
.To = "someone@somewhere"
.CC = ""
.BCC = ""
.Subject = "Mileage Report"
.HTMLBody = emailbody & "<br>" & .HTMLBody
.Attachments.Add Wb2.FullName
'.Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub