LeeStallan
New Member
- Joined
- Jan 18, 2014
- Messages
- 28
I have the following code in a workbook with employees to submit monthly timesheets. It was working fine with Outlook, but we have recently been migrated to Office365 and no longer have access to Outlook.
How can I get the code to work with Outlook365?
How can I get the code to work with Outlook365?
Rich (BB code):
Sub EmailJan()
'PURPOSE: Create email message with only Selected Worksheets attached
Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Paste Values
Sheets("Jan").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("E3:H3").Select
'Copy only selected sheets into new workbook
Set SourceWB = ActiveWorkbook
Sheets("Jan").Select
Sheets("Jan").Copy
Set DestinWB = ActiveWorkbook
'Determine Temporary File Path
TempFilePath = Environ$("temp") & "\"
'Determine Default File Name for InputBox
If SourceWB.Saved Then
DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
Else
DefaultName = SourceWB.Name
End If
'Ask user for a file name
TempFileName = Application.InputBox("What would you like to name your attachment? (No Special Characters!)", _
"File Name", Type:=2, Default:=DefaultName)
If TempFileName = False Then GoTo ExitSub 'Handle if user cancels
'Determine File Extension
If SourceWB.Saved = True Then
FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
Else
FileExtStr = ".xlsx"
End If
'Break External Links
ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)
'Loop Through each External Link in ActiveWorkbook and Break it
On Error Resume Next
For x = 1 To UBound(ExternalLinks)
DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
On Error GoTo 0
'Save Temporary Workbook
DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr
'Create Instance of Outlook
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
GoTo ExitSub
End If
On Error GoTo 0
'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)
'Create Outlook email with attachment
On Error Resume Next
With OutlookMessage
.To = admin@email.uk
.CC = ""
.BCC = ""
.Subject = TempFileName
.Body = "Monthly timesheet"
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display
End With
On Error GoTo 0
'Close & Delete the temporary file
DestinWB.Close SaveChanges:=False
Kill TempFilePath & TempFileName & FileExtStr
'Clear Memory
Set OutlookMessage = Nothing
Set OutlookApp = Nothing
'Optimize Code
ExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub