Frage von Fabidi, 78

Moin, ich möchte gerne eine Email automatisch aus Excel heraus abschicken (Lotus Notes) Wie mache ich es, dass ein bestimmter markierter Bereich versendet wird?

Sub SendNotesMail() 
Dim x As Integer 
Dim UserName As String 
Dim MailDbName As String 
Dim Recipient As Variant 
Dim Maildb As Object 
Dim MailDoc As Object 
Dim session As Object 
Dim stSignature As String 

With Application 
.ScreenUpdating = False 
.DisplayAlerts = False 

AWS = ActiveWorkbook.FullName 
Set Worksheet = Application.ActiveWorkbook.Worksheets.Item(1) 
Set session = CreateObject("Notes.NotesSession") 
Set Maildb = session.CURRENTDATABASE 
Range("B2:E35").Select 
Selection.Copy 
Set MailDoc = Maildb.createdocument 
MailDoc.Form = "Memo" 
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0) 
Recipient = "" 
MailDoc.display = "" 
MailDoc.copyto = "" 
MailDoc.subject = "prices" 
MailDoc.SAVEMESSAGEONSEND = saveit 
Call objnotesmaildoc.Save(True, False) 
Set ritem = MailDoc.CREATERICHTEXTITEM("Body") 
With ritem 
.APPENDTEXT ("Pls find below the updated prices:") 
.ADDNEWLINE (2) 
.APPENDTEXT ("" & vbCrLf & vbCrLf & stSignature) 
End With 

MailDoc.PostedDate = Now() 
MailDoc.Send (False), Recipient 
Set Maildb = Nothing 
Set MailDoc = Nothing 
Set AttachMe = Nothing 
Set session = Nothing 
Set EmbedObj = Nothing 
.ScreenUpdating = True 
.DisplayAlerts = True 
End With 
Range("a1").Select 
End Sub

Expertenantwort
von Ninombre, Community-Experte für Excel, 46

Wieweit funktioniert denn der bisherige Code? Ich hab kein Notes, kann Deinen Entwurf nicht selbst ausprobieren.

Ist der Bereich B2:E35 der Ausschnitt der als Tabelle reinsoll?

Ich kenne eine ähnliche Anforderung, die so umgesetzt war, allerdings mit HTML Format in der Mail. Geht das mit Notes, kenne es nicht.

Kommentar von Fabidi ,

Im Moment funktioniert es in sofern, dass die Email abgeschickt wird, wenn ich eine Email-Adresse einfüge. In der Email ist enthalten:
Betreff
"Pls find below the updated prices"
automatische Signatur

Das Problem ist, dass ich jeden belieben Text einfügen kann mit der Funktion .APPENDTEXT (" "), allerdings weiß ich nicht wie ich einen markierten Bereich einfügen kann (B2:E35).

Kommentar von Ninombre ,

Willst Du es als echte Tabelle einfügen oder nur die Textinhalte ggf. einfach hintereinander?

Für die Variante mit der Tabelle kenne ich nur den Weg über HTML Formatierung.

Dafür eine eigene Funktion, die aus deinem Ablauf heraus aufgerufen wird:

Function RangetoHTML(rng As Range)
Dim Fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set Fso = Nothing
Set TempWB = Nothing
End Function
In den Ablauf testhalber:

Dim rng as range
Set rng = Range("B2:E35")

Dann ist der Aufruf in meinem Beispiel allerdings ein anderer - es wird ein Outlook Obj erzeugt und dort

.htmlbody verwendet. Der Text für den gesamten E-Mail Body wird als String zusammengeschrieben. Der Tabelleninhalt wird über diese Funktion formatiert.

Du musst ausprobieren, ob es bei Dir funktioniert mit
.appendtext rangetohtml(rng)

Kommentar von Fabidi ,

Leider kommt die Fehlermeldung "Typen unverträglich".
Wenn ich Dim rng As Range eingebe, färbt sich das "Range" auch nicht blau, wie bei den anderen "Object" oder "String". Könnte daran liegen, dass er "Range" nicht erkennt.

Vielleicht hast du ja noch einen weiteren Vorschlag.

Bin für jede Hilfe offen.

Kommentar von Ninombre ,

Das DIM ist nicht das Problem - die Kombination, wie die Tabelle aus der von mir verlinkten Function aufbereitet wird passt dann nicht zu Notes.

Wäre es eine Option, die Inhalte der Tabelle als Texte mit Tab darzustellen?

Grob
.appendtext (B2 & vbtab & C2 & vbtab & D2 & vbtab & E2)
.appendnewline

das könnte man in eine for schleife packen

for i=2 to 35
.appendtext(cells(i,2).value & vbtab & cells(i,3).value & vbtab......
.appendnewline
next

Kommentar von Fabidi ,

Also die Idee ist sehr verlockend. Es hat auch zum Teil funktioniert, allerdings ist meine Frage, wie ich in den Zeilen weiter nach unten komme? Im Moment wird nur Zelle B2 angezeigt. (ist allerdings auch von B2 bis E2 verbunden und zentriert, also eine Zeile.

Vielen Dank bisher schonmal 

Kommentar von Fabidi ,

Moin, habe das Problem zum Teil selber gelöst. Hat super funktioniert. Meine Frage ist allerdings noch, ob man einige Zellen als fett angezeigt bekommen kann oder auch farblich hinterlegt oder farbige Schrift?

Antwort
von augsburgchris, 55

Bitte verwende die Funktion Codebeispiel einfügen hier im Editor. So kann keiner was mit deinem Code anfangen. 

Kommentar von Fabidi ,

Sorry, war gar nicht so beabsichtigt.

Hier etwas besser lesbar

Sub SendNotesMail()
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim session As Object
Dim stSignature As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False

AWS = ActiveWorkbook.FullName
Set Worksheet = Application.ActiveWorkbook.Worksheets.Item(1)
Set session = CreateObject("Notes.NotesSession")
Set Maildb = session.CURRENTDATABASE
Range("B2:E35").Select
Selection.Copy
Set MailDoc = Maildb.createdocument
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
Recipient = ""
MailDoc.display = ""
MailDoc.copyto = ""
MailDoc.subject = "prices"
MailDoc.SAVEMESSAGEONSEND = saveit
Call objnotesmaildoc.Save(True, False)
Set ritem = MailDoc.CREATERICHTEXTITEM("Body")
With ritem
.APPENDTEXT ("Pls find below the updated prices:")
.ADDNEWLINE (2)
.APPENDTEXT ("" & vbCrLf & vbCrLf & stSignature)
End With

MailDoc.PostedDate = Now()
MailDoc.Send (False), Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachMe = Nothing
Set session = Nothing
Set EmbedObj = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
End With
Range("a1").Select
End Sub

Keine passende Antwort gefunden?

Fragen Sie die Community

Weitere Fragen mit Antworten