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

 

[Micron]

There may be another way but the only way I know is to get the SP (SharePoint) server address. Open File Explorer. It has been a long time so I can't recall if you right click on a drive letter (such as F, but not C) or if you right click on the server name that is shown at the top of the drive letter list. I think it is the latter. What you're looking for in the right click menu is the properties option, and after selecting that you're looking for the path property of the server in the resulting dialog. It will start with two back slashes ( \\ ). If you find that, now you know what to look for going forward. I mention this first because I suspect you do not have a mapping to the SP server, and you will need that to discover the SP server path in this manner. You will probably need help with mapping to the SP server just so you can know the path, or perhaps your IT department will tell you what the path is. NOTE: this is not https://something/something... That is the web or intranet address and is not what I'm referring to. I'm referring to the network address of the SP server. Once you have that, you use the complete server path in your code (beginning with \\ ).

That is how I accessed Excel files on a SharePoint server from M$ Access code. If you want to modify these files, you will probably have to check them in and out (as if books from a library) otherwise I doubt you can edit their contents.
HTH

Please post more than a few code lines within code tags (use vba button on posting toolbar) to maintain indentation and readability. I'm too old to even bother to read code like that. If I had $1 for every time I've had to point this out in forums I could retire. Oh, wait a minute...

 

[Chris8630]

There may be another way but the only way I know is to get the SP (SharePoint) server address. Open File Explorer. It has been a long time so I can't recall if you right click on a drive letter (such as F, but not C) or if you right click on the server name that is shown at the top of the drive letter list. I think it is the latter. What you're looking for in the right click menu is the properties option, and after selecting that you're looking for the path property of the server in the resulting dialog. It will start with two back slashes ( \\ ). If you find that, now you know what to look for going forward. I mention this first because I suspect you do not have a mapping to the SP server, and you will need that to discover the SP server path in this manner. You will probably need help with mapping to the SP server just so you can know the path, or perhaps your IT department will tell you what the path is. NOTE: this is not https://something/something... That is the web or intranet address and is not what I'm referring to. I'm referring to the network address of the SP server. Once you have that, you use the complete server path in your code (beginning with \\ ).

That is how I accessed Excel files on a SharePoint server from M$ Access code. If you want to modify these files, you will probably have to check them in and out (as if books from a library) otherwise I doubt you can edit their contents.
HTH

Please post more than a few code lines within code tags (use vba button on posting toolbar) to maintain indentation and readability. I'm too old to even bother to read code like that. If I had $1 for every time I've had to point this out in forums I could retire. Oh, wait a minute...

Thank you Micron, I have been able to use your solution with the filepath to get it to work but now it's leaving me with a Book1 file I don't need. Updated code is as follows:

Sub EmailPDN()
Dim fileextstr As String
Dim a, b, c, d 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
Dim stranswer As String
a = Sheets("PDN").Range("B5")
b = Sheets("PDN").Range("M7")
c = Sheets("PDN").Range("M4")
d = Sheets("PDN").Range("M5")

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

If Dir("C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb") = "" Then
ActiveWorkbook.SaveCopyAs Filename:="C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb"

Set outapp = GetObject(, "Outlook.Application")
Set outmail = outapp.createitem(0)
Set outapp = GetObject(, "outlook.application")
Set outmail = outapp.createitemfromtemplate("C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\PDN EMAIL.oft") 'amend filepath and set up template
On Error Resume Next
With outmail
.attachments.Add "C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb"
.display
'.send
End With
On Error GoTo 0
Set outmail = Nothing
Set outapp = Nothing
'.Close savechanges:=False
'End With

Else
stranswer = MsgBox("There is already a similar PDN, would you like to make this version?", vbInformation + vbYesNo)
Application.ScreenUpdating = ture: Application.ScreenUpdating = False
If stranswer = vbYes Then
For i = 65 To 91
If Dir("C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & Chr(i) & ".xlsb") = "" Then
ActiveWorkbook.SaveCopyAs Filename:="C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & Chr(i) & ".xlsb"

Set outapp = GetObject(, "Outlook.Application")
Set outmail = outapp.createitem(0)
Set outapp = GetObject(, "outlook.application")
Set outmail = outapp.createitemfromtemplate("C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\PDN EMAIL.oft") 'amend filepath and set up template
On Error Resume Next
With outmail
.attachments.Add "C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & Chr(i) & ".xlsb"
.display
'.send
End With
On Error GoTo 0
Set outmail = Nothing
Set outapp = Nothing
'.Close savechanges:=False
'End With

Exit For
End If
Next i
End If
End If

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

 

[Micron]

Sorry, not going to read all of that.

Please post more than a few code lines within code tags (use vba button on posting toolbar) to maintain indentation and readability

But in case you're not aware I will point out that in this line:
Dim a, b, c, d As String d is a string, a,b and c are variants because they are not explicitly typed (data type that is).
You might want to consider grouping and using multi line declarations to reduce scrolling:

Dim fileextstr As String, a As String, b As String, c As String, d As String
Dim tempfilepath As String, tempfilename As String
Dim sourcewb As Workbook, destwb As Workbook

etc.

 

[Chris8630]

Code shortened and it's some where in this snippet that when saving the workbook as the requested file that it leaves me with a unwanted Book1

Sub EmailPDN()
Dim a As String, b As String, c As String, d As String, stranswer As String
Dim sourcewb As Workbook, destwb As Workbook
Dim outapp As Object, outmail As Object
Dim ws As Worksheet
Dim theactivewindow As Window, tempwindow As Window
a = Sheets("PDN").Range("B5")
b = Sheets("PDN").Range("M7")
c = Sheets("PDN").Range("M4")
d = Sheets("PDN").Range("M5")

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

If Dir("C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb") = "" Then
ActiveWorkbook.SaveCopyAs Filename:="C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb"

 

[Fluff]

@Chris8630 when posting code please use code tags. How to Post Your VBA Code

 

[Chris8630]

Sub EmailPDN()
Dim a As String, b As String, c As String, d As String, stranswer As String
Dim sourcewb As Workbook, destwb As Workbook
Dim outapp As Object, outmail As Object
Dim ws As Worksheet
Dim theactivewindow As Window, tempwindow As Window
a = Sheets("PDN").Range("B5")
b = Sheets("PDN").Range("M7")
c = Sheets("PDN").Range("M4")
d = Sheets("PDN").Range("M5")

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

If Dir("C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb") = "" Then
ActiveWorkbook.SaveCopyAs Filename:="C:\Users\" & b & "\OneDrive - ams OSRAM\# Product Discontinuation Notifications\" & c & "\" & d & "\" & a & ".xlsb"