WERNER SLABBERT
Board Regular
- Joined
- Mar 3, 2009
- Messages
- 107
Hi there ....
i recently found this thread
"
"
that does more or less what i want in my VBA but implementing it into my Current VBA is no easy feat,
would anyone be so kind as to help me piece it together... i would like the Macro to in addition send the saved pdf to a specific Recipient / s with a selected outlook account and specific signature in my case called "Nexus"
Here is my current Macro, it works great at saving the PDF and sends a mail, but no attachment and no specific account or sig... please help me...
i recently found this thread
"
HTML:
https://www.mrexcel.com/forum/general-excel-discussion-other-questions/710212-vba-code-convert-excel-pdf-email-attachment.html
that does more or less what i want in my VBA but implementing it into my Current VBA is no easy feat,
would anyone be so kind as to help me piece it together... i would like the Macro to in addition send the saved pdf to a specific Recipient / s with a selected outlook account and specific signature in my case called "Nexus"
Here is my current Macro, it works great at saving the PDF and sends a mail, but no attachment and no specific account or sig... please help me...
Code:
Option Explicit
Private Const CSIDL_DESKTOP = &H0
Private Type EMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As EMID
End Type
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Function GetSpecialfolder(CSIDL As Long) As String
Dim r As Long, Path$
Dim IDL As ITEMIDLIST
'Get the special folder
r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If r = 0 Then
'Create a buffer
Path$ = Space$(512)
'Get the path from the IDList
r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
'Remove the unnecessary chr$(0)'s
GetSpecialfolder = Left$(Path, InStr(Path, Chr$(0)) - 1)
Exit Function
End If
GetSpecialfolder = ""
End Function
Sub SaveIt()
On Error Resume Next 'In case it already exists
MkDir GetSpecialfolder(CSIDL_DESKTOP) & "\Famous_Brands" & "\" & Range("C7").Value
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
Dim Filename As String
Dim Path As String
Dim i As Integer
Dim Mail_Object
Dim Email_Subject
Dim o As Variant
Filename = Format(Date, "yyyy_mm_dd") & "_" & Range("J7").Value & "_" & Range("J8").Value
Path = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Path & "\Famous_Brands" & "\" & Range("C7").Value & "\" & Filename & ".Pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
ActiveWorkbook.SaveAs Filename:=Path & "\Famous_Brands" & "\" & "Complete_Job_Card_2018", _
FileFormat:=xlOpenXMLTemplateMacroEnabled, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=Path & "\" & "Complete_Job_Card_2018", _
FileFormat:=xlOpenXMLTemplateMacroEnabled, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Set Mail_Object = CreateObject("Outlook.Application")
With Mail_Object.CreateItem(o)
.Subject = "Famous Brands Repair Job Card" ' CHANGE TO SUIT
.To = "receptionpta@nexusgroup.co.za" 'CHANGE TO SUIT
.Body = "Machine Repaired and Ready for collection or courier." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "Werner Johan Slabbert" & Chr(13) & "Nexus Technical" 'Change comments to suit
.Attachments.Add Filename
.Send
End With
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub