Results 1 to 9 of 9

Create pdf and send email through Outlook using VBA- HELP!

This is a discussion on Create pdf and send email through Outlook using VBA- HELP! within the Excel Questions forums, part of the Question Forums category; Hi, I've spent several hours (even days) on this but I'm still stuck. So my manager wanted to have a ...

  1. #1
    New Member
    Join Date
    Jun 2013
    Posts
    7

    Default Create pdf and send email through Outlook using VBA- HELP!

    Hi,

    I've spent several hours (even days) on this but I'm still stuck. So my manager wanted to have a code for the Send Emails button below that would allow him to create the pdf files for the sheets specified in B7 and send them as attachments to addresses in D7-F7. It works fine for just one sheet but not two or more sheets. The sheets are separated by Alt+Enter (chr(10)). Please help! I would really appreciate it!



    Option Explicit


    Private Sub RDB_Outlook_Click()
    Dim StringTo As String, StringCC As String, StringBCC As String
    Dim ShArr() As String, FArr() As String, strDate As String
    Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
    Dim wb As Workbook, sh As Worksheet
    Dim DefPath As String
    Dim olApp As Object
    Dim olMail As Object
    Dim FileExtStr As String


    Dim ToArray As Variant
    Dim CCArray As Variant
    Dim BCCArray As Variant


    Dim StringFileNames As String
    Dim StringSheetNames As String
    Dim FileNamesArray As Variant
    Dim SheetNamesArray As Variant
    Dim I As Long, S As Long, F As Long
    Dim WrongData As Boolean


    If Len(ThisWorkbook.Path) = 0 Then
    MsgBox "This macro will only work if the file is Saved once", 48, "RDBMailPDFOutlook"
    Exit Sub
    End If


    If Me.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
    MsgBox "This macro will not work if the RDBMailOutlook worksheet is " & _
    "protected or if you have more then sheet selected(grouped)", 48, "RDBMailPDFOutlook"
    Exit Sub
    End If


    'Set folder where we save the temporary files
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
    DefPath = DefPath & "\"
    End If


    'Set reference to Outlook and turn of ScreenUpdating and Events
    Set olApp = CreateObject("Outlook.Application")
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    End With


    'Set cells with Red interior color to no fill(cells with wrong data)
    Range("A6").ListObject.DataBodyRange.Interior.Pattern = xlNone


    'Set rng to the first column of the table
    Set rng = Me.Range("A6").ListObject.ListColumns(1).Range


    For Each myCell In rng


    'Create mail if "Yes " in column A
    If LCase(myCell.Value) = "yes" Then


    StringTo = "": StringCC = "": StringBCC = ""
    S = 0: F = 0
    Erase ShArr: Erase FArr


    'Set Error Boolean to False
    WrongData = False


    'Check if there are Sheet names in column B


    'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
    If Trim(Me.Cells(myCell.Row, "B").Value) = "" Then S = 0


    'If there are sheet names in the B column S is the number of sheets it add to the Array
    If LCase(Trim(Me.Cells(myCell.Row, "B").Value)) <> "workbook" Then
    StringSheetNames = Me.Cells(myCell.Row, "B").Value
    SheetNamesArray = Split(StringSheetNames, Chr(10))


    For I = LBound(SheetNamesArray) To UBound(SheetNamesArray)
    On Error Resume Next
    If SheetNamesArray(I) <> "" Then
    If SheetExists(CStr(SheetNamesArray(I))) = False Then
    Me.Cells(myCell.Row, "B").Interior.ColorIndex = 3
    WrongData = True
    Else
    S = S + 1
    ReDim Preserve ShArr(1 To S)
    ShArr(S) = SheetNamesArray(I)
    End If
    End If
    On Error GoTo 0
    Next I
    Else
    'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
    S = -1
    End If


    'Check to Mail addresses in column D
    If Trim(Me.Cells(myCell.Row, "D").Value) <> "" Then
    StringTo = Me.Cells(myCell.Row, "D").Value
    ToArray = Split(StringTo, Chr(10), -1)
    StringTo = ""


    For I = LBound(ToArray) To UBound(ToArray)
    If ToArray(I) Like "?*@?*.?*" Then
    StringTo = StringTo & ";" & ToArray(I)
    End If
    Next I
    End If


    'Check to Mail addresses in column E
    If Trim(Me.Cells(myCell.Row, "E").Value) <> "" Then
    StringCC = Me.Cells(myCell.Row, "E").Value
    CCArray = Split(StringCC, Chr(10), -1)
    StringCC = ""


    For I = LBound(CCArray) To UBound(CCArray)
    If CCArray(I) Like "?*@?*.?*" Then
    StringCC = StringCC & ";" & CCArray(I)
    End If
    Next I
    End If


    'Check to Mail addresses in column F
    If Trim(Me.Cells(myCell.Row, "F").Value) <> "" Then
    StringBCC = Me.Cells(myCell.Row, "F").Value
    BCCArray = Split(StringBCC, Chr(10), -1)
    StringBCC = ""


    For I = LBound(BCCArray) To UBound(BCCArray)
    If BCCArray(I) Like "?*@?*.?*" Then
    StringBCC = StringBCC & ";" & BCCArray(I)
    End If
    Next I
    End If


    If StringTo = "" And StringCC = "" And StringBCC = "" Then
    Me.Cells(myCell.Row, "D").Resize(, 3).Interior.ColorIndex = 3
    WrongData = True
    End If


    'Check the other files that you want to attach in column H
    If Trim(Me.Cells(myCell.Row, "H").Value) <> "" Then
    StringFileNames = Me.Cells(myCell.Row, "H").Value
    FileNamesArray = Split(StringFileNames, Chr(10), -1)


    For I = LBound(FileNamesArray) To UBound(FileNamesArray)
    On Error Resume Next
    If FileNamesArray(I) <> "" Then
    If Dir(FileNamesArray(I)) <> "" Then
    If Err.Number = 0 Then
    F = F + 1
    ReDim Preserve FArr(1 To F)
    FArr(F) = FileNamesArray(I)
    Else
    Err.Clear
    Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
    WrongData = True
    End If
    Else
    Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
    WrongData = True
    End If
    End If
    On Error GoTo 0
    Next I
    End If


    'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
    If WrongData = True Then GoTo MailNot




    'Create PDF and Mail


    'Create Date/time string for the file name
    strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")


    'Copy the sheet(s)to a new workbook
    If S > 0 Then
    ThisWorkbook.Sheets(ShArr).Copy
    Set wb = ActiveWorkbook
    End If


    'You enter only "workbook" in colomn B to mail the whole workbook
    'Use SaveCopyAs to make a copy of the workbook
    If S = -1 Then
    FileExtStr = "." & LCase(Right(ThisWorkbook.Name, _
    Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
    Fname2 = DefPath & "TempFile " & FileExtStr


    ThisWorkbook.SaveCopyAs Fname2
    Me.Activate
    Set wb = Workbooks.Open(Fname2)
    Application.DisplayAlerts = False
    wb.Sheets(Me.Name).Delete
    Application.DisplayAlerts = True
    If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
    End If


    'Now we Publish to PDF
    If S <> 0 Then
    Fname = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
    " " & ".pdf"


    On Error Resume Next
    wb.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    FileName:=Fname, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
    On Error GoTo 0
    wb.Close False
    Set wb = Nothing
    End If


    On Error Resume Next
    Set olMail = olApp.CreateItem(0)
    With olMail
    .To = StringTo
    .CC = StringCC
    .BCC = StringBCC
    .Subject = Me.Cells(myCell.Row, "G").Value
    .Body = Me.Cells(myCell.Row, "I").Value
    If S <> 0 Then .Attachments.Add Fname


    If F > 0 Then
    For I = LBound(FArr) To UBound(FArr)
    .Attachments.Add FArr(I)
    Next I
    End If


    'Set Importance 0 = Low, 2 = High, 1 = Normal
    If LCase(Me.Cells(myCell.Row, "J").Value) = "yes" Then
    .Importance = 2
    End If


    'Display the mail or send it directly, see cell C3
    If LCase(Me.Range("C3").Value) = "yes" Then
    .Display
    Else
    .Send
    End If




    End With


    If S = -1 Then Kill Fname2
    Kill Fname
    On Error GoTo 0


    Set olMail = Nothing


    End If
    MailNot:
    Next myCell


    If LCase(Me.Range("C3").Value) = "no" Then
    MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
    "If you see Red cells in the table then the information in the cells is " & vbNewLine & _
    "not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
    "Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
    "Red cell or cells.", 48, "RDBMailPDFOutlook"
    End If




    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With


    Set olApp = Nothing
    End Sub




    Function SheetExists(wksName As String) As Boolean
    On Error Resume Next
    SheetExists = CBool(Len(ThisWorkbook.Sheets(wksName).Name) > 0)
    On Error GoTo 0
    End Function


    Private Sub BrowseAddFiles_Click()
    Dim Fname As Variant
    Dim fnum As Long


    If ActiveCell.Column = 8 And ActiveCell.Row > 6 Then
    Fname = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", _
    MultiSelect:=True)
    If IsArray(Fname) Then
    For fnum = LBound(Fname) To UBound(Fname)
    If fnum = 1 And ActiveCell.Value = "" Then
    ActiveCell.Value = ActiveCell.Value & Fname(fnum)
    Else
    If Right(ActiveCell, 1) = Chr(10) Then
    ActiveCell.Value = ActiveCell.Value & Fname(fnum)
    Else
    ActiveCell.Value = ActiveCell.Value & Chr(10) & Fname(fnum)
    End If
    End If
    Next fnum


    With Me.Range("J1").EntireColumn
    .ColumnWidth = 255
    .AutoFit
    End With
    With Me.Rows
    .AutoFit
    End With
    End If
    Else
    MsgBox "Select a cell in the ""Attach other files"" column", 48, "RDBMailPDFOutlook"
    End If
    End Sub






    Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 3 And Target.Column < 7 And Target.Row > 6 Then
    With Range(Target.Address)
    .Hyperlinks.Delete
    End With
    End If
    End Sub

  2. #2
    Board Regular Michael M's Avatar
    Join Date
    Oct 2005
    Location
    Western NSW
    Posts
    10,200

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    Have you had a look at Ron De Bruins site regarding sending e-mails to multiple recipients.
    www.rondebruin.nl/sendmail

    I'd also consider splitting the E-mail addresses to remove the ALT + Enter
    Regards
    Michael M
    ---------------------------------------
    The more I learn, the less I seem to know.....A Please and Thank You cost nothing !
    It's easier to debug if we can see the whole macro !
    work 2003, Home 2007

    - Posting guidelines, forum rules and terms of use

    - To download Mr Excel HTML Maker

    - Try searching for your answer first, see how

    - Read the FAQs

    - List of BB codes


    [CODE]Place Your Code Here[/CODE]

  3. #3
    New Member
    Join Date
    Jun 2013
    Posts
    7

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    Hi Michael. Yes I have taken a look at the website and couldn't find the answer. Also, I'm trying to attach multiple sheets to the email, not send to multiple recipients. Sorry for the confusion. Thanks for your help though, Michael!

  4. #4
    Board Regular Michael M's Avatar
    Join Date
    Oct 2005
    Location
    Western NSW
    Posts
    10,200

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    Ok, I'd suggest then, that you post a sample of the data layout, either here or uploaded to a site like dropbox and then post a link back here.
    If the sheet names are in one cell and the list of names are in one cell....I can see a bit of work involved.
    I usually use an input box or message box to allow the user to select the files from explorer rather than have a list on the worksheet.
    Regards
    Michael M
    ---------------------------------------
    The more I learn, the less I seem to know.....A Please and Thank You cost nothing !
    It's easier to debug if we can see the whole macro !
    work 2003, Home 2007

    - Posting guidelines, forum rules and terms of use

    - To download Mr Excel HTML Maker

    - Try searching for your answer first, see how

    - Read the FAQs

    - List of BB codes


    [CODE]Place Your Code Here[/CODE]

  5. #5
    New Member
    Join Date
    Jun 2013
    Posts
    7

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    Michael M,

    Thank you so much for your help! I've figured it out so I'll mark it resolved now. The problem lied with the FileName cell; it simply doesn't accept Alt+Enter as a delimiter. Thanks again, Michael!

    Quote Originally Posted by Michael M View Post
    Ok, I'd suggest then, that you post a sample of the data layout, either here or uploaded to a site like dropbox and then post a link back here.
    If the sheet names are in one cell and the list of names are in one cell....I can see a bit of work involved.
    I usually use an input box or message box to allow the user to select the files from explorer rather than have a list on the worksheet.

  6. #6
    New Member
    Join Date
    Jun 2013
    Posts
    6

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    Hi , Would you please share with basic excel file , so that i can understand the coding

  7. #7
    New Member
    Join Date
    Jun 2013
    Posts
    6

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    HI ,

    Please help me ,

    Actually i have 1700 Pdf file in an folder regarding form 16 and 16A, and i have maintain an excel file , i share with you
    Employee Code Name Email Id Path
    1350 Rajinder Prasad Rajinder.yadav1980@gmail.com C:\New Folder\From 16

    would you please help me to give VBA Coding that its pick PDF file from folder employee code wise and send a mail with respective email address via outlook .

    i am highly appreciated if some body help me please ................
    Last edited by rajinder; Jul 4th, 2013 at 10:47 AM. Reason: typing error

  8. #8
    Board Regular
    Join Date
    Jul 2009
    Posts
    1,059

    Default Re: Create pdf and send email through Outlook using VBA- HELP!


  9. #9
    New Member
    Join Date
    Jun 2013
    Posts
    6

    Default Re: Create pdf and send email through Outlook using VBA- HELP!

    Dear Sir,

    Thanks but its not pick file employee code wise, would you please send me fresh VBA coding if u don't mind .
    its a gr8 help for me . please ..........

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com