VBA to save file to SharePoint and attach to outlook template saved in SharePoint

[Chris8630]

Hi all

I'm hoping this is a quick fix. I have a file which I want to attach a copy of a sheet to a separate workbook, save that workbook down and then attach it to an Outlook template. All files are saved/to be saved in SharePoint. The code I have currently is:

Sub Email()
Dim fileextstr As String
Dim a 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 ws As Worksheet
Dim theactivewindow As Window
Dim tempwindow As Window
a = Sheets("PDN").Range("B5")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set sourcewb = ActiveWorkbook
With sourcewb
Set theactivewindow = ActiveWindow
Set tempwindow = .NewWindow
.Sheets(Array("PDN")).Copy
End With
tempwindow.Close
Set destwb = ActiveWorkbook
If Not IsEmpty(destwb.LinkSources(xlExcelLinks)) Then
For Each link In destwb.LinkSources(xlExcelLinks)
destwb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
Sheets("PDN").Select
Range("B5").Copy
Range("B5").PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
'With destwb
'If Val(Application.Version) < 12 Then
'fileextstr = ".xls": fileformatnum = -4143
'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 With
'tempfilepath = "sharepoint address here"
'tempfilename = a
Set outapp = GetObject(, "Outlook.Application")
Set outmail = outapp.createitem(0)
With destwb
ActiveWorkbook.SaveAs "sharepoint address here" & a & ".xlsx"
On Error Resume Next
Set outapp = GetObject(, "outlook.application")
Set outmail = outapp.createitemfromtemplate("sharepoint address here/PDN%20EMAIL.oft")
On Error Resume Next
With outmail
.attachments.Add destwb.FullName
.display
'.send
End With
On Error GoTo 0
Set outmail = Nothing
Set outapp = Nothing
.Close savechanges:=False
End With
'Kill tempfilepath & tempfilename & fileextstr
'End With
Sheets("PDN").Select
Range("L1").Copy
Range("B5").PasteSpecial xlPasteFormulas, operation:=xlNone, skipblanks:=False, Transpose:=False
Set outmail = Nothing
Set outapp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

This works no problem if everything is located on a standard network drive but is failing to save onto sharepoint.

Any suggestions/code re-writes/etc are greatly appreciated