none
Macro to e-mail distribution list format RRS feed

  • Question

  • I inherited the code below. It generate a pop-up box to propt the user to select a distribution list to e-mail form to as an MS Word Macro. The first 5 options work and are displayed on screen. The last two options 6 & 7 don't display and don't work.

    Does anyone know how I can get options 6 & 7 to work?

    Option Explicit

    Public RefNumber As String

    Sub RequestAppr()

        

        Dim EmailList As String

        Dim EmailTo As String

        Dim FileExtStr As String

        Dim OutApp As Object

        Dim OutMail As Object

        Dim TempFilePath As String

        Dim TempFileName As String

       

       

    ' a.  1 = Group1- Rick

    '   i.  The following emails will be attached to this group:

    '       1.  user1@myemail.com

    '       2.  user2@myemail.com

    '       3.  user3@myemail.com

    'b.  2 = Group2 - Rhonda

    '   i.  The following emails will be attached to this group:

    '       1. user4@myemail.com

    '       2.  user2@myemail.com

    '       3.  user3@myemail.com

    'c.  3 = Group3

    '   i.  The following emails will be attached to this group

    '       1.  user5@myemail.com

    '       2.  user6@myemail.com

    '       3.  user7@myemail.com

    '       4.  user10@myemail.com

    'd.  4 = Group4

    '   i.   The following emails will be attached to this group

    '       1.  user8@myemail.com

    '       2.  luser9@myemail.com

    '       3.  user7@myemail.com

    'e.  5 =Group5

    '   i.   The following emails will be attached to this group

    '       1.  user8@myemail.com

    '       2.  luser9@myemail.com

    '       3.  user10@myemail.com

    'f.  6 = Group6

    '   i.  The following emails will be attached to this group

    '       1.  user5@myemail.com

    '       2.  user11@myemail.com

    'g.  7 = Group7

    '   i.  The following emails will be attached to this group

    '       1.  user5@myemail.com

    '       2.  user12@myemail.com

      

        'Make a copy of the file/Open it/Mail it/Delete it

        'If you want to change the file name then change only TempFileName

       

         EmailTo = InputBox(vbNewLine & "CANCEL = Return - No Email" & vbNewLine & _

                         vbNewLine & """1"" = Group1" & _

                         vbNewLine & """2"" = Group2 & _

                         vbNewLine & """3"" = Group3" & _

                         vbNewLine & """4"" = Group4" & _

                         vbNewLine & """5"" = Group5" & _

                         vbNewLine & """6"" =Group 6", _

                         vbNewLine & """7"" =Group 7", _

     

                         "Send E-Mail for Approval", "")

         

        If InStr("1,2,3,4,5", EmailTo) = 0 Then

            MsgBox "Invalid Selection", vbCritical, "Cannot E-Mail for Approval"

            Exit Sub

        Else

            If EmailTo = "" Then

                Exit Sub

            End If

        End If

     

        If EmailTo = 1 Then

            EmailList = "user1@myemail.com; user2@myemail.com; user3@myemail.com"

        Else

            If EmailTo = 2 Then

            EmailList = "rkrerowicz@myemail.com; user2@myemail.com; user3@myemail.com"

            Else

                If EmailTo = 3 Then

                EmailList = "user5@myemail.com; user6@myemail.com; user7@myemail.com; user10@myemail.com"

                Else

                    If EmailTo = 4 Then

                    EmailList = "user8@myemail.com; luser9@myemail.com; user7@myemail.com"

                    Else

                        If EmailTo = 5 Then

                        EmailList = "user8@myemail.com; luser9@myemail.com; user10@myemail.com"

                        Else

                            If EmailTo = 6 Then

                            EmailList = "user5@myemail.com; user11@myemail.com"

                            Else

                                If EmailList = 7 Then

                                EmailList = "user5@myemail.com; user12@myemail.com"

                                Else

                            End If

                        End If

                    End If

                End If

            End If

        End If

        End If

     

        'EmailList = "admintest@myemail.com" ' Testing

        TempFilePath = Environ$("temp") & "\"

        TempFileName = "VICF Approval Request " & RefNumber

        FileExtStr = ".docx"

     

        Application.Documents.Add ActiveDocument.FullName

         'the next line saves the copy to your location and name

        ActiveDocument.SaveAs TempFilePath & TempFileName & FileExtStr

         'next line closes the copy leaving you with the original document

     

       

        Set OutApp = CreateObject("Outlook.Application")

        Set OutMail = OutApp.CreateItem(0)

     

        On Error Resume Next

        With OutMail

            .To = EmailList

            .CC = ""

            .BCC = ""

            .Subject = "Submitted VICF Approval Request Ref#: " & RefNumber

            .Body = ""

            .Attachments.Add TempFilePath & TempFileName & FileExtStr

            'You can add other files also like this

            '.Attachments.Add ("C:\test.txt")

            .Send   'or use .Display

        End With

        On Error GoTo 0

                            

        'Delete the file

        Kill TempFilePath & TempFileName & FileExtStr

        MsgBox "This ICF Approval Request Has Been Submitted" & vbNewLine & vbNewLine & _

                "Your Copy Can be Found in Outlook Sent Items"

        ActiveDocument.Saved = True

     

        If Documents.Count = 1 Then

            Application.Quit

        Else

            ActiveDocument.Close

       

    End If

    End Sub

     

    Thursday, January 29, 2015 3:35 PM

Answers