Worksheet Form Controls Stop Working After VBA Export to PDF

SincereApathy

New Member
Joined
Feb 20, 2016
Messages
4
As the title states, I have some VBA code setup to export sheets to a PDF report. There are check boxes on the worksheet to show and hide certain columns. After I run the code and successfully export to PDF, the form controls no longer work - I clicked them an nothing happens. Even if I save and come back into the file, they still don't work. After rebuilding it I saved a backup so I can keep attempting to fix them problem.

Has anyone encountered this before? I have no idea where to begin to try to fix this...
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
18,199
Office Version
2013
Platform
Windows
when you export to PDF are you exporting a COPY of the workbook ?
does your code save the workbook as an XLSX before saving as a PDF ??
Maybe you should post your code ??
 

SincereApathy

New Member
Joined
Feb 20, 2016
Messages
4
This is the code that deals with exporting the file to PDF:

Code:
sTempPath = Environ$("temp") & "\"    
sFileName = "Report_" & Format(Date, "m-dd")

Sheets(sSheets).Select
    
ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=sTempPath & sFileName & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=False, IgnorePrintAreas:=False
sSheets is an array that contains varying sheet names based on form selections regarding which information to include in the report.
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
18,199
Office Version
2013
Platform
Windows
Is that ALL the code....I can't see a problem in the snippet you posted...it must be causing issues somewhere else in the code ?
Has it just started happening ?
Was it working fine previously ??
 

SincereApathy

New Member
Joined
Feb 20, 2016
Messages
4
Here is ALL of the code related to the action - the complete action is to export to .PDF as a temporary file to use in an email attachment:

Here is the class library for the email process:
Code:
Option Explicit

Private colEmailTo As Collection
Private colEmailCC As Collection
Private colEmailBCC As Collection
Private colAttachment As Collection
Private sSubject As String
Private sBody As String
Private sSignatureTextPath As String
Private sSignatureHTMLPath As String


Private Sub Class_Initialize()
'Create collections to hold defined items
    Set colEmailTo = New Collection
    Set colEmailCC = New Collection
    Set colEmailBCC = New Collection
    Set colAttachment = New Collection
End Sub


Private Sub Class_Terminate()
'Release all collections
    Set colEmailTo = Nothing
    Set colEmailCC = Nothing
    Set colEmailBCC = Nothing
    Set colAttachment = Nothing
End Sub


'---------------------------------------------------------------------------------------
' Writing to properties/collections
'---------------------------------------------------------------------------------------
Public Property Let AddToRecipient(s As String)
'Add a "To" recipient
    If EmailIsValid(s) Then
        colEmailTo.Add s
    Else
        MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
               "to be a valid email address", vbOKOnly, "Invalid address!"
    End If
End Property


Public Property Let AddCCRecipient(s As String)
'Add a "CC" recipient
    If EmailIsValid(s) Then
        colEmailCC.Add s
    Else
        MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
               "to be a valid email address", vbOKOnly, "Invalid address!"
    End If
End Property


Public Property Let AddBCCRecipient(s As String)
'Add a "BCC" recipient
    If EmailIsValid(s) Then
        colEmailBCC.Add s
    Else
        MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
               "to be a valid email address", vbOKOnly, "Invalid address!"
    End If
End Property


Public Property Let AttachFile(s As String)
'Add an attachement
    If AttachmentPathValid(s) Then
        colAttachment.Add s
    Else
        MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
               "to exist!", vbOKOnly, "Invalid file path!"
    End If
End Property


Public Property Let AddSignatureHTML(s As String)
'Check if HTML file exists
    Dim sTemp As String
    Dim sHTML As String


    'Look for signature file assuming Windows Vista/7 folder structure
    sTemp = Dir("C:\Users\" & Environ("username") & _
                "\AppData\Roaming\Microsoft\Signatures\" & s & ".htm")
    If Len(sTemp) > 0 Then
        sTemp = "C:\Users\" & Environ("username") & _
                "\AppData\Roaming\Microsoft\Signatures\" & s & ".htm"
        GoTo ValidPath
    End If


    'Test if system is Windows XP or earlier
    sTemp = Dir("C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\" & s & ".htm")
    If Len(sTemp) > 0 Then
        sTemp = "C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\" & s & ".htm"
        GoTo ValidPath
    End If


    'File can not be located.  Inform user
    MsgBox "Sorry, but I cannot locate the " & s & " signature file!", _
           vbOKOnly, "Invalid signature!"


ValidPath:
    'Test if HTML contains an image
    If InStr(1, SignatureText(sTemp), "<v:imagedata src=") Then<br />        MsgBox " sorry,="" but="" i="" could="" not="" use="" your="" html="" signature="" file."="" &="" vbnewline="" _
               "(Unfortunately this routine doesn't handle HTML signatures" & vbNewLine & _
               "with images.  Please try a plain text signature or an HTML" & vbNewLine & _
               "signature that does not have any images embedded.", vbOKOnly + vbInformation, _
               "Signature discarded."
        Exit Property
    Else
        sSignatureHTMLPath = sTemp
    End If


End Property


Public Property Let AddSignatureText(s As String)
'Check if text file exists
    Dim sTemp As String


    'Look for signature file assuming Windows Vista/7 folder structure
    sTemp = Dir("C:\Users\" & Environ("username") & _
                "\AppData\Roaming\Microsoft\Signatures\" & s & ".txt")
    If Len(sTemp) > 0 Then
        sSignatureTextPath = "C:\Users\" & Environ("username") & _
                             "\AppData\Roaming\Microsoft\Signatures\" & s & ".txt"
        Exit Property
    End If


    'Test if system is Windows XP or earlier
    sTemp = Dir("C:\Documents and Settings\" & Environ("username") & _
                "\Application Data\Microsoft\Signatures\" & s & ".txt")
    If Len(sTemp) > 0 Then
        sSignatureTextPath = "C:\Documents and Settings\" & Environ("username") & _
                             "\Application Data\Microsoft\Signatures\" & s & ".txt"
        Exit Property
    End If


    'File can not be located.  Inform user
    MsgBox "Sorry, but I cannot locate the " & s & " signature file!", _
           vbOKOnly, "Invalid signature!"


End Property


Public Property Let Subject(s As String)
'Record the subject
    sSubject = s
End Property


Public Property Let Body(s As String)
'Record the Body
    sBody = s
End Property


'---------------------------------------------------------------------------------------
' Public Class Methods
'---------------------------------------------------------------------------------------
Public Sub Send()
'Method to preview the email


    Dim objOL As Object
    Dim objMail As Object


    'Bind to Outlook
    Set objOL = CreateObject("Outlook.Application")


    'Create a new email
    Set objMail = objOL.CreateItem(0)
    CreateMessage objMail


    'Preview the message
    objMail.Send


    'Release all objects
    Set objMail = Nothing
    Set objOL = Nothing
End Sub


Public Sub Preview()
'Method to preview the email


    Dim objOL As Object
    Dim objMail As Object


    'Bind to Outlook
    Set objOL = CreateObject("Outlook.Application")


    'Create a new email
    Set objMail = objOL.CreateItem(0)
    CreateMessage objMail


    'Preview the message
    objMail.display


    'Release all objects
    Set objMail = Nothing
    Set objOL = Nothing
End Sub


'---------------------------------------------------------------------------------------
' Internal Methods
'---------------------------------------------------------------------------------------
Private Function AttachmentPathValid(sFilePath As String) As Boolean
'Check if attachment exists


'Check if file/folder exists
    If Len(Dir(sFilePath)) = 0 Then GoTo Invalid


    'Ensure that user did not supply a folder
    If Right(sFilePath, 1) = Application.PathSeparator Then GoTo Invalid


    'Tests passed
    AttachmentPathValid = True
    Exit Function


Invalid:


End Function


Private Sub CreateMessage(ByRef oMailItem As Object)
'Create Outlook email based on data stored in internal class collections


    Dim lIterate As Long
    Dim sTemp As String


    With oMailItem
        'Add TO Recipients
        If colEmailTo.count > 0 Then
            For lIterate = 1 To colEmailTo.count
                sTemp = sTemp & colEmailTo.Item(lIterate) & ";"
            Next lIterate
            .To = Left(sTemp, Len(sTemp) - 1)
            sTemp = vbNullString
        End If


        'Add CC Recipients
        If colEmailCC.count > 0 Then
            For lIterate = 1 To colEmailCC.count
                sTemp = sTemp & colEmailCC.Item(lIterate) & ";"
            Next lIterate
            .CC = Left(sTemp, Len(sTemp) - 1)
            sTemp = vbNullString
        End If


        'Add BCC Recipients
        If colEmailBCC.count > 0 Then
            For lIterate = 1 To colEmailBCC.count
                sTemp = sTemp & colEmailBCC.Item(lIterate) & ";"
            Next lIterate
            .BCC = Left(sTemp, Len(sTemp) - 1)
            sTemp = vbNullString
        End If


        'Add subject
        .Subject = sSubject


        'Add body
        If Len(sSignatureTextPath) > 0 Then
            'Body and plain text signature
            .Body = sBody & vbNewLine & vbNewLine & SignatureText(sSignatureTextPath)


        ElseIf Len(sSignatureHTMLPath) > 0 Then
            'Convert body to HTML and append signature
            .HTMLBody = ConvertTextToHTML(sBody) & "

" & sTemp
        Else
            'Body with no signature
            .Body = sBody
        End If




        'Add any attachments
        If colAttachment.count > 0 Then
            For lIterate = 1 To colAttachment.count
                .Attachments.Add colAttachment.Item(lIterate)
            Next lIterate
        End If
    End With
End Sub


Private Function EmailIsValid(sEmailAddress As String) As Boolean
'Check if email address is valid


'NOTE: This is a very basic validation, only checking for the provision of
'      an email domain and suffix.  Much more complicated verification could
'      be done if desired.


    Dim aryAddress() As String


    On Error GoTo Invalid


    'Split email into recipient and domain
    aryAddress() = Split(sEmailAddress, "@")


    'Check if there is a .  Must be at least 2nd character
    If Not InStr(1, aryAddress(1), ".") > 2 Then GoTo Invalid


    'Tests passed
    EmailIsValid = True
    Exit Function


Invalid:
    'Function returns FALSE by default
End Function


Private Function SignatureText(ByVal sFile As String) As String




'Extracts contents of signature file
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    SignatureText = ts.readall
    ts.Close
End Function


Private Function ConvertTextToHTML(ByVal sText As String) As String
'Convert plain text into HTML for email body
    ConvertTextToHTML = Replace(sText, "&", "&")
    ConvertTextToHTML = Replace(sText, "<", "<")
    ConvertTextToHTML = Replace(sText, ">", ">")
    ConvertTextToHTML = Replace(sText, vbNewLine, "
")
    ConvertTextToHTML = Replace(sText, vbCrLf, "
")


End Function
Here is the email code that builds the sheet name string:
Code:
If firstHalfCB.Value = True Or secondHalfCB.Value = True Or OverallCB.Value = True Then    If PDFsheets = "" Then
            PDFsheets = "Sheet1"
    End If
    
    If GroupsCB.Value = True Then
        If PDFsheets = "" Then
            PDFsheets = "Sheet2"
        Else
            PDFsheets = PDFsheets & "," & "Sheet2"
        End If
    End If
    
    If ResultsCB.Value = True Then
        If PDFsheets = "" Then
            PDFsheets = "Sheet3"
        Else
            PDFsheets = PDFsheets & "," & "Sheet3"
        End If
    End If

    Call GenerateEmail(PDFsheets)
Here is the code that generates the email using the class library from above:
Code:
Public Sub GenerateEmail(sReportSheet As String)
    Dim cl As Range
    Dim sTempPath As String
    Dim sFileName As String
    Dim sEmailSheet As String
    Dim emailList As String
    Dim emailRow As Integer
    Dim sSheets() As String
    Dim i As Integer
    
    emailRow = 3
    
    Do
    
    If Sheets("Email List").Cells(emailRow, 2).Value <> "" And emailRow = 3 Then
    emailList = Sheets("Email List").Cells(emailRow, 2).Value
    emailRow = emailRow + 1
    
    ElseIf Sheets("Email List").Cells(emailRow, 2).Value <> "" And emailRow > 3 Then
    emailList = emailList & "; " & Sheets("Email List").Cells(emailRow, 2).Value
    emailRow = emailRow + 1
    
    End If
    
    Loop Until Sheets("Email List").Cells(emailRow, 2).Value = ""
    'Define the names of your worksheets here
    
    sEmailSheet = "Email List"  '<-- The worksheet that holds your email table
    

    sTempPath = Environ$("temp") & "\"
    
    sFileName = "Report_" & Format(Date, "m-dd")
        
        'Remove any existing instance of the file
        On Error Resume Next
        Kill sTempPath & sFileName & ".pdf"
        On Error GoTo 0
        
        'Export a temporary copy of the file
            
        sSheets = Split(sReportSheet, ",")
        
        Sheets(sSheets).Select
    
        ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sTempPath & sFileName & ".pdf", Quality:=xlQualityStandard, _
            IncludeDocProperties:=False, IgnorePrintAreas:=False
    
        ActiveWindow.View = xlPageBreakPreview
        ActiveWindow.View = xlNormalView
    
    
        'Email the file
        Call EmailViaOutlook(emailList, sTempPath & sFileName & ".pdf")
    
        'Remove the temp file
        On Error Resume Next
        Kill sTempPath & sFileName & ".pdf"
        On Error GoTo 0
   
End Sub

Private Sub EmailViaOutlook(sTo As String, sAttach As String)
'Create the email object
    Dim oEmail As New clsOutlookEmail
    Dim attachLen As Integer
    
    With oEmail
        'Add a recipient
        .AddToRecipient = sTo
 
        'Set the subject
        .Subject = ""


        'Set the body
        .Body = ""
 
        'Add an attachment
        
        .AttachFile = sAttach


        'Preview the email (or use .Send to send it)
        .Preview
    End With
   
    'Release the email object
    Set oEmail = Nothing
End Sub
</v:imagedata>
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
18,199
Office Version
2013
Platform
Windows
It seems like an awful lot of code to attach a PDF file to an email
I can't see any reason for the check boxes to be affected, are you able to share the workbook ??
If so, I'll send you a PM and you can email it to me !!
 

SincereApathy

New Member
Joined
Feb 20, 2016
Messages
4
I appreciate your efforts Michael. After wasting nearly an entire day I finally realized the soberingly simple solution to my problem. After running the code I showed you, the 3 sheets that were selected to export to PDF remained selected after the macro finished. Therefore, by adding in a line to select another sheet that will never be part of the PDF, I clear the multiple sheet selection. Then, I just re-select the original sheet I was on to go back to it and everything works again. :mad:

Sorry for wasting your time... I know I wasted way too much of mine.
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
18,199
Office Version
2013
Platform
Windows
:LOL:..:LOL:....don't you just love Excel sometimes, glad you got it sorted ...:biggrin:...(y)
 
Last edited:

Forum statistics

Threads
1,082,316
Messages
5,364,483
Members
400,802
Latest member
RichBRich

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top