Re: Macro to save as PDF with auto filename as cell value

Andrew

Just to let you know that the code below works well for me, and thank you again. 

Command Button: -

1. Generates a pdf of the ActiveSheet
2. Saves pdf to a specific location, indicated in Cell H1, with an auto Filename based on the Sheet Date within Cell I3, formatted as YYMMDD
3. Opens Outlook and displays email with pdf attached (file with date "Now")
4. Auto fills Recipients, reading from Cell C50
5. Email Body as required

When i'm happy i will change code to automatically send email not display.

for reference:-

Cell H1:  ="I:\2017 - 2018\Operations Unit\Day Sheets\"&"DS_"&TEXT(I3,"yymmdd")&".PDF"

Private Sub Email_Sheet_Click()

Dim objOutlook As Object
    Dim objMail As Object
    Dim signature As String
    Dim oWB As Workbook
    Set oWB = ActiveWorkbook
    
    
    
     s = Range("h1").Value	
  
 '
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
         s, Quality:=xlQualityStandard, IncludeDocProperties _
         :=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         
         
    PDF_File = "Insert Path here\DS_" & Format(Now, "YYMMDD") & ".pdf"
 
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
        
    With objMail
        .Display
    End With
        signature = objMail.HTMLbody
    With objMail
        .To = ActiveSheet.Range("C50")
        .Cc = ActiveSheet.Range("C55")
        .Subject = "Insert Subject Here"
        .HTMLbody = "<font face=" & Chr(34) & "Calibri" & Chr(34) & " size=" & Chr(34) & 4 & Chr(34) & ">" & "Hi," & "<br> <br>" & "Insert email body here" & "<br> <br>" & signature & "</font>"
        .Attachments.Add PDF_File
        .Save
        .Display
    End With

    Set objOutlook = Nothing
    Set objMail = Nothing
End Sub

Andrew Jones 

code as you share not works in window 7/10 64 bit .  my cvode be below

Declare Function RegOpenKeyA Lib "advapi32.dll" ( _
ByVal Key As Long, _
ByVal SubKey As String, _
NewKey As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long

Sub PrintPDF()
Dim sPath As String
Dim strDefaultPrinter As String
Dim strOutFile As String
Dim lngRegResult As Long
Dim lngResult As Long
Dim dhcHKeyCurrentUser As Long
Dim PDFPath As String
Const dhcRegSz As Long = 1

dhcHKeyCurrentUser = &H80000001
strDefaultPrinter = Application.ActivePrinter

sPath = "D:\JOBCARD201920"
PDFPath = sPath

strOutFile = PDFPath & "\" & Range("G3").VALUE & ".pdf"


lngRegResult = RegOpenKeyA(dhcHKeyCurrentUser, "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
lngResult)
lngRegResult = RegSetValueEx(lngResult, Application.Path & "\Excel.exe", 0&, dhcRegSz, ByVal strOutFile, Len(strOutFile))
lngRegResult = RegCloseKey(lngResult)

ThisWorkbook.ActiveSheet.PrintOut copies:=1, ActivePrinter:="Adobe PDF"
Application.ActivePrinter = strDefaultPrinter

end sub