Mail verzenden met messagebox
Beste forumleden,
Desgevraagd bijgaand de hele code.
Een groot aantal regels heeft te maken met het kopiëren van gegevens naar een ander werkblad.
De code:
Dim Werkboek As Workbook
Dim Werkblad As Worksheet
Dim Printbereik As Range
Sub Factuur_genereren()
'datum volgende reiniging
Blad4.Select
Laatstefactuurnummer = Range("B13") + 1
relatienummer = Range("F1")
datumvolgendereiniging = Range("D24")
totaalbedrag = Range("D41")
BTW = Range("G39")
dagboek = Range("G41")
grootboek = Range("G43")
Blad1.Select
For x = 1 To 8999
If Range("W" & x) = relatienummer Then
Range("T" & x) = datumvolgendereiniging
Range("Z" & x) = Laatstefactuurnummer
End If
Next
'aanmaken van factuurnummer
Blad4.Select
Range("B13").Value = Laatstefactuurnummer
'printen van de factuur
ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True, ignoreprintareas:=False
'opslaan PDF bestand
Range("A1
53").ExportAsFixedFormat xlTypePDF, Filename:="D:\DSR CLEANING\Facturen" & Range("B13").Value, openafterpublish:=False
Blad5.Select
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
'Opheffen beveiliging
ActiveSheet.Unprotect
'overnemen van gegevens vanaf de factuur naar werkblad Boekingen
Range("A16").Select
Selection.EntireRow.Insert
Huidigerij = ActiveCell.Row
Range("A" & Huidigerij).Select
Blad4.Select
Range("F1").Select
Application.CutCopyMode = False
Selection.Copy
Blad5.Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Blad4.Select
Range("B13").Select
Application.CutCopyMode = False
Selection.Copy
Blad5.Select
Range("B" & Huidigerij).Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Range("Q5").Select
Application.CutCopyMode = False
Selection.Copy
Range("C" & Huidigerij).Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Blad4.Select
Range("D41").Select
Application.CutCopyMode = False
Selection.Copy
Blad5.Select
Range("M" & Huidigerij).Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Blad4.Select
Range("G41").Select
Application.CutCopyMode = False
Selection.Copy
Blad5.Select
Range("G" & Huidigerij).Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Blad4.Select
Range("G43").Select
Application.CutCopyMode = False
Selection.Copy
Blad5.Select
Range("J" & Huidigerij).Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Blad4.Select
Range("G39").Select
Application.CutCopyMode = False
Selection.Copy
Blad5.Select
Range("N" & Huidigerij).Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
'Beveiliging inschakelen
ActiveSheet.Protect
BewaarEmailInConceptenFactuur
WissenFactuurRegels
End Sub
Sub BewaarEmailInConceptenFactuur()
Set Werkboek = ActiveWorkbook
Set Werkblad = Werkboek.Sheets("Factuur")
Set Printbereik = Werkblad.Range("A1
52")
maakPDFFactuur
maakEmailFactuur
MsgBox "De e-mail is met succes opgeslagen in uw standaard map Postvak Uit!", vbInformation
End Sub
Sub maakPDFFactuur()
Blad4.Select
If Dir(pdfDocument) <> "" Then Kill pdfDocument
Printbereik.ExportAsFixedFormat xlTypePDF, pdfDocument
End Sub
Sub maakEmailFactuur()
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = [B11]
.BCC = "rene1010@hotmail.nl"
.Subject = "Factuur"
sPic = "'D:\DSR Cleaning\Afbeeldingen\logo-10.jpg'"
.HTMLBody = "<HTML>" & [A17] & "<p><p>Bijgaand doen wij u de factuur toekomen voor de door ons verrichte werkzaamheden. <p>" & _
"Heeft u gekozen voor een vaste frequentie? Noteer a.u.b. de volgende reinigingsdatum: " & [D24] & "<p>" & _
"Zorg er voor dat wij de geplande werkzaamheden uit kunnen voeren en voorkom daarmee teleurstellingen.<p><p>" & _
"Met vriendelijke groet, <p><p>" & _
"<img src = " & sPic & ">" & _
"<p><p>René Loorbach" & _
"<br>KvK: 70867011 " & _
"<br>Website: dsrcleaning.nl " & _
"<br>Mobiel: 06-29990446"
.Attachments.Add pdfDocument
If MsgBox("De factuur per e-mail verzenden?", vbQuestion + vbYesNo) = vbYes Then Send
End If
End With
Set objMail = Nothing
Set objOutlook = Nothing
End Sub
Function pdfDocument()
pdfDocument = Environ("USERPROFILE") & "\Bijlage.pdf"
End Function
Sub WissenFactuurRegels()
'wissen inhoud factuurregels
Blad4.Select
Range("A28:C36").ClearContents
Range("F23").Select
ActiveCell.FormulaR1C1 = "Nee"
Range("E24").ClearContents
Range("B27").Select
ActiveCell.FormulaR1C1 = "Reinigingswerkzaamheden volgens afspraak"
Range("B41").Select
ActiveCell.FormulaR1C1 = "betalen met bankoverschrijving"
Range("F1").Select
End Sub