01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54 |
|
Sub MailMitPDFundSignatur()
Dim sKW As String, sDateiname As String, sBer As String, sMailtext As String
Dim WSh As Worksheet
Dim iZeile As Long, iZlMax As Long, bCheck As Boolean
Set WSh = ThisWorkbook.Sheets("Tabelle1")
sKW = InputBox("Bitte geben Sie die Kalenderwoche (KW) ein, die per Mail gesendet werden soll.")
If sKW = "" Then Exit Sub
iZlMax = WSh.Cells(WSh.Rows.Count, "B").End(xlUp).Row
For iZeile = 3 To iZlMax
With WSh.Cells(iZeile, "B")
If .Value = sKW And bCheck = False Then
bCheck = True
sBer = .Offset(, -1).Address
ElseIf .Value <> sKW And bCheck Then
sBer = sBer & ":" & .Offset(-1, 2).Address
GoTo Weiter
ElseIf iZeile = iZlMax And bCheck Then
sBer = sBer & ":" & .Offset(, 2).Address
GoTo Weiter
End If
End With
Next iZeile
MsgBox "Die KW '" & sKW & "' wurde nicht gefunden!", vbCritical, "Mail senden"
Exit Sub
Weiter:
' PDF erzeugen
sDateiname = WSh.Parent.Path & "\" & "Bestellung_" & Format(Date, "YYYYMMDD") & ".pdf"
WSh.Range(sBer).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sDateiname, _
Quality:=xlQualityStandard, OpenAfterPublish:=False
sBer = "$A$2:$D2," & sBer
' Mail kreieren
With CreateObject("Outlook.Application").CreateItem(0)
.Getinspector.Display ' sorgt für die Signatur
.To = "anIhn@web.de" ' Empfänger
.cc = "Auchan@gmx.de" ' Kopie an
.Subject = "Ich bin ein Betreff" ' Betreff
sMailtext = "Hallo,¶¶" _
& "anbei die Daten und die PDF Datei zur weiteren Verwendung.¶"
.htmlBody = Replace(sMailtext, "¶", "<br>") & .htmlBody
' Bereich in Mail einfügen, ggf. mit Pos spielen
WSh.Range(sBer).Copy
With .Getinspector.WordEditor.Application.Selection
.Start = Len(sMailtext) + 1: .Paste
End With
' Anlage dran
If Dir$(sDateiname) <> "" Then .Attachments.Add sDateiname
End With
End Sub
|