Posts by emwaj

    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.


    ROOMING LIST.xlsm





    Sub Mail_Range() ' SEND BY EMAIL RANGE FROM GENERAL


    '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
    Else


    End If
    If InStr(EmailAddress, "@") = 0 Then
    MsgBox "Adresse email invalide. Action interrompue!", vbOKOnly, "Adresse invalide"
    Exit Sub
    Else
    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 = " "


    Else
    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)


    Source.Copy
    With Dest.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial Paste:=xlPasteValues
    .Cells(1).PasteSpecial Paste:=xlPasteFormats
    .Cells(1).Select
    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
    Else
    '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



    'email


    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
    .display


    End With


    .Close savechanges:=False
    End With


    'WRITE TIME
    [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



    'WRITE TIME
    [W10] = Date
    [W9] = EmailAddress
    [W11] = Time


    ActiveSheet.Range("a1").Select


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


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




    End Sub