vba code

[sue68]

Hi



I have a word document that is currently set up for the workers to fill in and click the send and save button, this pdf's the page and publishes it to Sharepoint page and emails to a group email.
I need to add 2nd page which will not be pdf'd with the 1st page but will be sent as a 2 page word document to a email.

I'm not sure where to start with the below code.

1. How do I get the code to pick only the first page and not the second (will have workers private info on and is not for publishing)
2. Do I do the 2 page word doc first and then the pdf'ing

Option Explicit
Dim strFilename As String
Sub SaveAndSend()
    Dim strDate As String
    Dim strNoti As String
    Dim strTitle As String
    
    strDate = ActiveDocument.SelectContentControlsByTag("EventDate").Item(1).Range.Text
    
    If IsDate(strDate) Then
        strDate = Format(strDate, "yyyy-mm-dd")
    Else
        MsgBox "Please select an event date.", vbExclamation, "Date Error"
        Exit Sub
    End If
    
    strNoti = ActiveDocument.SelectContentControlsByTag("NotificationNumber").Item(1).Range.Text
    strTitle = ActiveDocument.SelectContentControlsByTag("ShortText").Item(1).Range.Text
    
    If Not IsNumeric(strNoti) Or Len(strNoti) <> 9 Then
        MsgBox "Please enter a valid notification number.", vbExclamation, "Notification Error"
        Exit Sub
    End If
    
    If Left(strTitle, 5) = "Enter" Then
        MsgBox "Please enter short text.", vbExclamation, "Title Not Entered"
        Exit Sub
    End If
    
    
    
    strFilename = strDate & " " & strNoti & " " & strTitle & ".pdf"
    
    ActiveDocument.SaveAs FileName:= _
    "https://spo.bhpb.com/sites/COLMTAmac...Notifications/" & strFilename, FileFormat:=wdFormatPDF
    
    ActiveDocument.SaveAs FileName:= _
    "\\necmacfil01\bcc_data\Transfer\Sue Jones\NHSEC_DIR_CTRL_DOCS_(MRE)\" & strFilename, FileFormat:=wdFormatPDF
    
    Call SendDocumentAsAttachment
End Sub
Sub SendDocumentAsAttachment()
    Dim strDate As String
    Dim strNoti As String
    Dim strTitle As String
    
    strDate = ActiveDocument.SelectContentControlsByTag("EventDate").Item(1).Range.Text
    
    If IsDate(strDate) Then
        strDate = Format(strDate, "yyyy-mm-dd")
    Else
        MsgBox "Please select an event date.", vbExclamation, "Date Error"
        Exit Sub
    End If
    
    strNoti = ActiveDocument.SelectContentControlsByTag("NotificationNumber").Item(1).Range.Text
    strTitle = ActiveDocument.SelectContentControlsByTag("ShortText").Item(1).Range.Text
    
    If Not IsNumeric(strNoti) Or Len(strNoti) <> 9 Then
        MsgBox "Please enter a valid notification number.", vbExclamation, "Notification Error"
        Exit Sub
    End If
    
    If Left(strTitle, 5) = "Enter" Then
        MsgBox "Please enter short text.", vbExclamation, "Title Not Entered"
        Exit Sub
    End If
    
    
    
    strFilename = strDate & " " & strNoti & " " & strTitle & ".pdf"
    
    Dim bStarted As Boolean
     
    Dim oOutlookApp As Outlook.Application
     
     'You'll need to add the Outlook Object Library to VBA Tools References
     
    Dim oItem As Outlook.MailItem
    strTitle = ActiveDocument.SelectContentControlsByTag("ShortText").Item(1).Range.Text
    
    On Error Resume Next
     
    ' If Len(ActiveDocument.Path) = 0 Then 'Document has not been saved
         
        'so save it
    ' ActiveDocument.Save
        
    ' End If
     
     'see if Outlook is running and if so turn your attention there
     
    Set oOutlookApp = GetObject(, "Outlook.Application")
     
    If Err <> 0 Then 'Outlook isn't running
         
         'So fire it up
         
        Set oOutlookApp = CreateObject("Outlook.Application")
         
        bStarted = True
         
    End If
     
     'Open a new e-mail message
     
    Set oItem = oOutlookApp.CreateItem(olMailItem)
     
    With oItem 'and add the detail to it
         
        .To = "DL-COL-NEC-MACEventNotification@bhpb.com" 'send to this address
        .CC = ""
         '.BCC = ""
         
        .Subject = strDate & " " & strNoti & " " & strTitle 'This is the message subject
         
        
        .Attachments.Add Source:="\\necmacfil01\bcc_data\Transfer\Sue Jones\NHSEC_DIR_CTRL_DOCS_(MRE)\" & strFilename
        .Display
         
    End With
     
   ' If bStarted Then 'If the macro started Outlook, stop it again.
         
   '     oOutlookApp.Quit
         
   ' End If
     
     'Clean up
     
    Set oItem = Nothing
     
    Set oOutlookApp = Nothing
     
End Sub

[macropod]

You can't send the attachment without first saving the file. Accordingly, you could save & send the full file, then delete the 2nd page and re-save. However, your code doesn't appear to actually send the email, so you'd need to save the 2-page email-attachment version with a different name (or, at least, in a different folder) from the 1-page version that is to be kept. For the latter, you could use the ExportAsFixedFormat method to create a PDF with just the first page. The alternative is to save the email version, then delete the 2nd page and use Save As to save the version that is to be kept. Either way, you'll probably want to delete the email version once it's been sent.

[gmayor]

You don't need to redefine all the string variables in your second macro, just pass those that you need from the first to the second. You can create a temporary PDF file that contains only the first page and attach that to the e-mail.

It is better to test for the placeholder text when validating content controls and note that while Set oOutlookApp = GetObject(, "Outlook.Application") is a valid way of accessing outlook if it is open, Set oOutlookApp = CreateObject("Outlook.Application") does not allow Outlook to behave as you might expect. You should therefore use the code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to start Outlook.

This is especially so if you want to add body text to the e-mail as shown below. If you require more information about this it is linked from the web page.

The following will attach the first page of the document in PDF format and send it to the named recipient. I have added a couple of lines of code to validate the filename, in case someone enters an invalid character in the Title control

Option Explicit

Sub SaveAndSend()
Dim strPDF As String
Dim strDate As String
Dim strNoti As String
Dim strTitle As String
Dim orng As Range
Dim strFilename As String
Dim arrInvalid() As String
Dim lngIndex As Long

    If ActiveDocument.SelectContentControlsByTag("EventDate").Item(1).ShowingPlaceholderText = True Then
        MsgBox "Please select an event date.", vbExclamation, "Date Error"
        Exit Sub
    End If

    strDate = ActiveDocument.SelectContentControlsByTag("EventDate").Item(1).Range.Text

    If IsDate(strDate) Then
        strDate = Format(strDate, "yyyy-mm-dd")
    Else
        MsgBox "Please select an event date.", vbExclamation, "Date Error"
        Exit Sub
    End If

    If ActiveDocument.SelectContentControlsByTag("NotificationNumber").Item(1).ShowingPlaceholderText = True Then
        MsgBox "Please enter a valid notification number.", vbExclamation, "Notification Error"
        Exit Sub
    End If

    strNoti = ActiveDocument.SelectContentControlsByTag("NotificationNumber").Item(1).Range.Text

    If IsNumeric(strNoti) = False Then
        MsgBox "Please enter a valid notification number.", vbExclamation, "Notification Error"
        Exit Sub
    End If

    If ActiveDocument.SelectContentControlsByTag("ShortText").Item(1).ShowingPlaceholderText = True Then
        MsgBox "Please enter short text.", vbExclamation, "Title Not Entered", "Title Error"
        Exit Sub
    End If
    strTitle = ActiveDocument.SelectContentControlsByTag("ShortText").Item(1).Range.Text

    strFilename = strDate & " " & strNoti & " " & strTitle
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")

    'Remove any illegal filename characters
    For lngIndex = 0 To UBound(arrInvalid)
        strFilename = Replace(strFilename, Chr(arrInvalid(lngIndex)), Chr(95))
    Next lngIndex
    strFilename = strFilename & ".pdf"

    'next section not required for attachment
    ActiveDocument.SaveAs FileName:= _
                          "https://spo.bhpb.com/sites/COLMTAmac...Notifications/" & strFilename, FileFormat:=wdFormatPDF
    ActiveDocument.SaveAs FileName:= _
                          "\\necmacfil01\bcc_data\Transfer\Sue Jones\NHSEC_DIR_CTRL_DOCS_(MRE)\" & strFilename, FileFormat:=wdFormatPDF
    'end of section  not required for attachment

    'Get the first page of the document
    Set orng = ActiveDocument.Range
    orng.Collapse 1
    orng.Select
    orng.End = ActiveDocument.Bookmarks("\page").Range.End - 1
    'and export it as PDF
    orng.ExportAsFixedFormat OutputFilename:=Environ("TEMP") & Chr(92) & strFilename, _
                             ExportFormat:=wdExportFormatPDF, _
                             OpenAfterExport:=False
    'Send the message with the first page PDF
    SendDocumentAsAttachment Environ("TEMP") & Chr(92) & strFilename, strTitle, strDate, strNoti
    Set orng = Nothing
End Sub

Sub SendDocumentAsAttachment(strFilename As String, _
                             strTitle As String, _
                             strDate As String, _
                             strNoti As String)
'pass the values from the calling macro
Dim bStarted As Boolean
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Document
Dim orng As Range
Dim oOutlookApp As Object

    'You don't need to add the Outlook Object Library to VBA Tools References
    'But you will need the code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    'to start Outlook properly

    Set oOutlookApp = OutlookApp()
    Set oItem = oOutlookApp.CreateItem(0)
    With oItem    'and add the detail to it
        .to = "DL-COL-NEC-MACEventNotification@bhpb.com"    'send to this address
        .CC = ""
        .Subject = strDate & " " & strNoti & " " & strTitle    'This is the message subject
        .Attachments.Add strFilename
        .Display 'This line is required
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set orng = wdDoc.Range
        orng.Collapse 1
        orng.Text = "This is the body of the message before the signature"
        '.send 'restore this line after testing
    End With
    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set orng = Nothing
End Sub