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
55
56
57
58
59
60
61
62
63
64
65 |
|
Private Function Range2Html(oBereich As Range) As String
' Gibt den angegebenen Bereich als HTML zurück, incl.Bilder
Dim sTmpDatei As String, sTmp As String, sTmpVz As String
Dim iff As Integer, P As Long
' Bereich in Datei exportieren
With oBereich
sTmpVz = Environ$("temp") & "\"
sTmpDatei = sTmpVz & Format(Now, "ddmmyy" & Int(Timer) * 10) & ".htm"
.Parent.Parent.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=sTmpDatei, Sheet:=.Parent.Name, _
Source:=.Address, _
HtmlType:=xlHtmlStatic).Publish Create:=True
iff = FreeFile
Open sTmpDatei For Input As iff
Range2Html = Replace(Input(LOF(iff), iff), "align=center x:publishsource=", _
"align=left x:publishsource=")
Close iff
' Feststellen, ob auch Bilder im Bereich sind
P = InStr(1, Range2Html, "<link rel=File-List href=") + 26
If P > 26 Then
sTmp = Mid$(Range2Html, P, InStr(P, Range2Html, "/filelist.xml") - P)
Range2Html = Replace(Range2Html, sTmp, sTmpVz & sTmp)
End If
End With
On Error Resume Next
Kill sTmpDatei
Kill sTmpVz & sTmp
End Function
Private Sub Mail_BereichalsBereich_Word1()
' Sendet Mail mit integriertem Bereich als Bereich mit Signatur
Dim WSh1 As Worksheet, WSh2 As Worksheet
Dim sMailtext As String, sBer As String, iZeile As Long
iZeile = Selection.Row
sBer = Selection.EntireRow.Address ' Kopierbereich ganze Zeile
Set WSh1 = ThisWorkbook.Sheets("Tabelle1") ' Blatt mit Maildaten
Set WSh2 = ThisWorkbook.Sheets("Tabelle2") ' Datenblatt
sMailtext = "Hier ist die kopierte Tabellenzeile:" & vbLf & vbLf
With CreateObject("Outlook.Application").CreateItem(0)
.Getinspector.Display ' Signatur holen und anzeigen
.Subject = "Tabellenzeile kopiert" ' Betreff
.To = WSh1.Range("A" & iZeile).Value ' Empfänger
.CC = WSh1.Range("B" & iZeile).Value ' ggf. Kopie
.body = sMailtext & vbLf & .body
WSh2.Range(sBer).Copy ' Bereich kopieren
With .Getinspector.WordEditor.Application.Selection
.Start = Len(sMailtext)
.Paste ' Bereich in Mail einfügen
End With
End With
End Sub
|