Forum Discussion

Joe Gray's avatar
Joe Gray
Copper Contributor
May 30, 2017
Solved

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

Hi I recently used the following Macro, provided by Gary's Student, to create a PDF from an active sheet, generate a unique Filename based on a cell ref and save it to a specific location.   This m...
Macros & VBA
Need Help
  • Andrew Jones's avatar
    Andrew Jones
    Jun 02, 2017

    This is code I use.

    End Sub

    Private Sub Email()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim signature As String
    Dim oWB As Workbook
    Set oWB = ActiveWorkbook
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
        
    With objMail
        .Display
    End With
        signature = objMail.HTMLbody
    With objMail
        .To = oWB.Sheets("Sheet1").Range("A1").Value
        ''.SentOnBehalfOfName = ""
        .Subject = strMySubject
        ''.body = "Dear Sir," & vbNewLine & vbNewLine & "Add stuff here" & vbNewLine & vbNewLine & signature
        .HTMLbody = "<font face=" & Chr(34) & "Calibri" & Chr(34) & " size=" & Chr(34) & 4 & Chr(34) & ">" & "Dear Sir," & "<br> <br>" & "Add stuff here" & "<br> <br>" & signature & "</font>"
        .Attachments.Add (strSaveFileName + ".pdf")
        .Display
    End With

    Set objOutlook = Nothing
    Set objMail = Nothing
    
End Sub
Andrew Jones's avatar
Andrew Jones
Copper Contributor
Jun 02, 2017

And this is code to export to PDF

 

You obviously need a full path as a string to save the file to

 

 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strSaveFileName, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
                ThisWorkbook.SaveAs Filename:=strSaveFileName, FileFormat:=xlOpenXMLTemplateMacroEnabled
Jitender_modgil's avatar
Jitender_modgil
Copper Contributor
Jul 01, 2020

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

Resources