Create PDF from active worksheet, attatch to mail and add signature

Draikonis

New Member
Joined
Jul 8, 2010
Messages
7
Hello,

I've been working on this ultimate macro for days. I've been using Ron de Bruin's macros from his site (http://www.rondebruin.nl), but I have some issues. I can't get it to work properly.

First off, my macro creates a PDF file for my workbook. First problem here is that it creates a PDF of all sheets, not just the active one. I will never ever have to create a PDF of any other sheets than the very first one (called "Blad1" in my workbook).

However, the macro lets me save the PDF file as and attaches it to a new e-mail in Microsoft Office Outlook 2007 (edited in HTML-format). Everything works fine, until I take a look at the signature. Here something peculiar happens. The logotype (a .jpg-file) looks broken. I have attached the htm-document according to Ron de Bruin's code, and I have double and triple-checked the file paths. The htm-document itself works fine.

All I could find out when looking for any obvious errors was when I saved the e-mail as a HTML-file, opened in Internet Explorer and clicked "show source". Scrolling down to the bottom, I found something very strange. Here's what the lines look like in my original htm-document:

Code:
<v:imagedata src="informell-filer/image001.jpg" o:title="image001"/> </v:shape><![endif]--><![if !vml]><img width=346 height=77 src="informell-filer/image001.jpg" v:shapes="_x0000_i1025"><![endif]><o:p></o:p></span></p>
Everything works fine. The logotype called image001.jpg is located in the folder informell-filer.

In the source of the e-mail however, the same lines look like this:

Code:
</v:shape><![endif]--><![if !vml]><img width=346 height=77 src="This%20is%20the%20Subject%20line-filer/image001.gif" alt=image001 v:shapes="Bild_x0020_1"><![endif]><span style='color:navy;mso-no-proof:yes'><o:p></o:p></span></p>
Somehow the macro changes the folder name in the file path to the same as the subject of the e-mail, but still it's adding -filer (meaning -files).

I have no idea how to fix this, but I suspect there is something not right with the functions.

Here is the full code I use, called RDB_Workbook_To_PDF_And_Create_Mail_with_signature().

Code:
'Code to create a PDF and a Mail
'Only working if you use Outlook


Sub RDB_Workbook_To_PDF_And_Create_Mail_with_signature()
    Dim FileName As String
    
    Dim OutApp As Object
    Dim OutMail As Object
    
   


On Error Resume Next
    'Call the function with the correct arguments
    FileName = RDB_Create_PDF(ActiveWorkbook, "", True, False)

    'For a fixed file name and overwrite it each time you run the macro use
    'RDB_Create_PDF(ActiveWorkbook, "C:\Users\Ron\Test\YourPdfFile.pdf", True, True)
    
    
    If FileName <> "" Then
        RDB_Mail_PDF_Outlook FileName, "ron@debruin.nl", "This is the subject", _
                             "See the attached PDF file with the last figures" _
                           & vbNewLine & vbNewLine & "Regards Ron de bruin", False

                           
                           
    Else
        MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
               "Microsoft Add-in is not installed" & vbNewLine & _
               "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
               "The path to Save the file in arg 2 is not correct" & vbNewLine & _
               "You didn't want to overwrite the existing PDF if it exist"
    End If
    
End Sub

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Sub Mail_Outlook_With_Signature_Html()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2010
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrBody As String
    Dim SigString As String
    Dim Signature As String

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)

    StrBody = "<H3><B>Dear Customer</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    'Use the second SigString if you use Vista as operating system

    SigString = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signaturer\informell.htm"

    'SigString = "C:\Users\" & Environ("username") & _
     "\AppData\Roaming\Microsoft\Signatures\informell.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = StrBody & "<br><br>" & Signature
        'You can add files also like this
        '.Attachments.Add ("C:\test.txt")
        .Display   'or use .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub




'This are the functions that the macros above will use
'Do not forget to copy them in your module


Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function



Function RDB_Mail_PDF_Outlook(FileNamePDF As String, strto As String, _
                              StrSubject As String, StrBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim SigString As String
    Dim Signature As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    SigString = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signaturer\informell.htm"
                ' Anpassad för winXP
    
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    StrBody = "Här följer det senaste serviceprotokollet." & _
              "<br>"
    ' Text included in e-mail

    On Error Resume Next
    With OutMail
        .To = ThisWorkbook.Sheets("Blad1").Range("A1").Value
        ' find mail addesses, blad=sheet
        .CC = ""
        .BCC = ""
        .Subject = "Senaste Serviceprotokoll"
        .HTMLBody = StrBody & "<br><br>" & Signature
        .Attachments.Add FileNamePDF
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Function



Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
                                      OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
'This function will create a PDF with every sheet with
'a sheet level name variable <NamedRange> in it
    Dim FileFormatstr As String
    Dim Fname As Variant
    Dim Ash As Worksheet
    Dim sh As Worksheet
    Dim ShArr() As String
    Dim s As Long
    Dim SheetLevelName As Name

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        'We fill the Array with sheets with the sheet level name variable
        For Each sh In ActiveWorkbook.Worksheets
            If sh.Visible = -1 Then
                Set SheetLevelName = Nothing
                On Error Resume Next
                Set SheetLevelName = sh.Names(NamedRange)
                On Error GoTo 0
                If Not SheetLevelName Is Nothing Then
                    s = s + 1
                    ReDim Preserve ShArr(1 To s)
                    ShArr(s) = sh.Name
                End If
            End If
        Next sh

        'We exit the function If there are no sheets with
        'a sheet level name variable named <NamedRange>
        If s = 0 Then Exit Function

        If FixedFilePathName = "" Then

            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If


        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        Application.ScreenUpdating = False
        Application.EnableEvents = False

        'Remember the ActiveSheet
        Set Ash = ActiveSheet

        'Select the sheets with the sheet level name in it
        Sheets(ShArr).Select

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then
            Create_PDF_Sheet_Level_Names = Fname
        End If

        Ash.Select

        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Function
Not all functions are used but I decided to keep them since I might need them to merge together the codes and make the whole 'active sheet into PDF'-thing achievable.

I have Office 2007 and my Windows XP is in Swedish.

I am very thankful for any help! I've been resarching for solutions to these problems for days now.

Sincerely,
Amanda
<!--[endif]-->
 

Forum statistics

Threads
1,081,458
Messages
5,358,808
Members
400,513
Latest member
sdrowsick

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top