sending 2 worksheets in attachment by email

  • Hey

    I am not very good in VBA and it took me a few months to get this resultat with a lot of help...

    This macro is opening an email with the active sheet in where she is .
    Here some explanation what does the macro do (because the input boxes are with French explanations) :

    1. ask you to write an email (you need to write @ to continue)
    2. ask you to write the name of the person to whom you send the email ("Dear X"). If you don't write anything it will be "Dear Mrs/Mr")
    3. ask you to write some comments for the email body, if you want.
    4. display the email with the active sheet (only range from A1 to column T, and until last filled row (but no less than row 18))

    All is working very good until now.

    I would like to add a feature that if I choose to add as attachment to the email a second worksheet (called "daily") the macro would add it in attachment .

    But I really don't know what to change so as to make this change because presently this macro is only adding the active worksheet.

    If someone knows what to do/how to do, and if it is not too much difficult, I would be happy for some help .
    But if it is too much complicated and time consuming, so nevermind :(

    I join here the excel file.



    'Working in Excel 2000-2016
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailAddress As String
    Dim Remark As String
    Dim agentname As String
    Dim LastRow As Long

    EmailAddress = InputBox("Veuillez entrer ci-dessous l'adresse email à laquelle vous souhaitez envoyer la rooming list. (L'hôtel recevra en pièce jointe les données contenues dans l'onglet général sans le PNR ni la remarque sur le règlement.)", "Adresse email")
    If EmailAddress = "" Then
    MsgBox "Vous devez préciser un email pour l'envoi. Action interrompue!", vbOKOnly, "Entrée invalide"

    Exit Sub

    End If
    If InStr(EmailAddress, "@") = 0 Then
    MsgBox "Adresse email invalide. Action interrompue!", vbOKOnly, "Adresse invalide"
    Exit Sub
    End If

    agentname = InputBox("Veuillez entrer le prenom de l'hotelier.", "Nom hotelier")
    If agentname = "" Then
    agentname = "Mrs/Mr"
    End If

    Remark = InputBox("Veuillez entrer ci-dessous vos remarques, si vous en avez. Elles seront intégrées dans l'email. ATTENTION! Ne cliquez pas sur la touche ENTER pour aller à la ligne", "Remarques")
    If Remark = "" Then
    Remark = " "

    End If

    msg = "Do you want to send to the hotel also a daily rooming list?"
    Dialogstyle = vbQuestion + vbYesNo
    Title = "Daily rooming list"
    RESPONSE = MsgBox(msg, Dialogstyle, Title)
    If RESPONSE = vbNo Then

    End If
    If RESPONSE = vbYes Then

    MsgBox "here a macro which will save the other sheet called 'daily' and join it to this email attachment"
    End If

    Set Source = Nothing

    ActiveSheet.Unprotect "obrat"

    Columns("J").EntireColumn.Hidden = True
    Columns("L").EntireColumn.Hidden = True

    'copy from row 18 until last filled row (from column A to T)

    LastRow = WorksheetFunction.Max(18, Range("B" & Rows.Count).End(xlUp).Row)
    Set Source = Range("A1:T" & LastRow).SpecialCells(xlCellTypeVisible)

    On Error GoTo 0

    If Source Is Nothing Then
    MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
    Exit Sub
    End If

    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    With Dest.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial Paste:=xlPasteValues
    .Cells(1).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    End With

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

    TempFileName = Range("B1") & " " & Range("C1")

    If Val(Application.Version) < 12 Then
    'You use Excel 97-2003
    FileExtStr = ".xls": FileFormatNum = -4143
    'You use Excel 2007-2016
    FileExtStr = ".xlsx": FileFormatNum = 51
    End If

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

    With Dest
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next


    With OutMail

    .To = EmailAddress
    .Cc = ""
    .BCC = ""
    .Subject = Range("B1") & " " & Range("C1")
    .body = "Dear" & " " & agentname & Chr(10) & Chr(10) & "Please find in attachment the rooming list." & Chr(10) & "Remarks:" & " " & Remark & Chr(10) & Chr(10) & "Best regards," & Chr(10) & Chr(10) & Application.UserName & " " & "-" & " " & "Obrat Tours"
    .Attachments.Add Dest.FullName

    End With

    .Close savechanges:=False
    End With

    [W10] = Date
    [W9] = EmailAddress
    [W11] = Time

    Kill TempFilePath & TempFileName & FileExtStr

    CreateObject("WScript.Shell").Popup "Cette rooming list est prête à être envoyée. ", 2, " "

    Set OutMail = Nothing
    Set OutApp = Nothing

    Columns("J").EntireColumn.Hidden = False
    Columns("L").EntireColumn.Hidden = False

    [W10] = Date
    [W9] = EmailAddress
    [W11] = Time


    ActiveSheet.Protect Password:="obrat", DrawingObjects:=False, AllowFormattingCells:=True

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

    End Sub

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!