AW: Per VBA erstellte Daten per Lotus Notes mailen
10.05.2006 15:49:19
Franz
Hallo,
ich habe mal den Hinweis auf die Einbindung des e-mail-Versands per Lotus Notes aufgegriffen und in das bisherige Projekt eingearbeitet. Alle Parameter, die dabei im Lotus-Makro gesetzt werden sind mir auch nicht geläufig. Ich habe im wesentlichen die Eingabeparameter für die Lotusprozedur aufbereitet. Außerdem habe ich das Ganze so gestaltet, dass die Eingabeparameter im Hauptmakro berechnet werden und als Parameter an die Lotusprozedur übergeben werden. Für den Betreff-Text und den Mail-Text kannst du natürlich auch Inhalte aus einer Tabelle verwenden.
Ich habe Test und WindowsXP, Excel 2003 und LotusNotes 6.5 durchgeführt. klappt einwandfrei.
Option Explicit
Sub WRDateienerstellen()
' WR-Datei-Erstellungs-Makro
Dim wb1 As Workbook, wbneu As Workbook, WR(), I As Integer 'geändert!!!
Dim Dateiname As String, Verz As String, UVerz As String, t, D As String, Z As String
' Dehklarationen für e-mail-Versand
Dim emailBetreff As String, emailText As String, emailAn As String, emailKopie As String
Dim emailBKopie As String, Zeile As Long, Spalte As Integer, SpalteWR As Integer
Sheets("Command-Button").Select
t = Range("a1").Value
D = Format(Now, "YYYY-MM-DD")
Z = Format(Now, "HH.MM")
Set wb1 = ActiveWorkbook
Verz = wb1.Path
UVerz = t & " erzeugt am " & D & " um " & Z & " Uhr"
If Dir(Verz & "\" & UVerz, vbDirectory) = "" Then
MkDir (Verz & "\" & UVerz)
End If
' geänderte Zeilen ---Anfang, WR einlesen
Application.ScreenUpdating = False
wb1.Sheets("WR_vorhanden").Activate
wb1.Sheets("WR_vorhanden").PivotTables("Pivot-Tabelle1").PivotSelect "WR[All]", xlLabelOnly
ReDim WR(1 To Selection.Rows.Count)
For I = 1 To UBound(WR)
WR(I) = Selection(I)
Next I
wb1.Sheets("Command-Button").Activate
Application.ScreenUpdating = True
For I = 1 To UBound(WR)
' geänderte Zeilen ---Ende
With wb1
With .Sheets("Alle Marktranking")
.PivotTables("PivotTable1").PivotCache.Refresh
.PivotTables("PivotTable1").PivotFields("WR").CurrentPage = WR(I)
End With
With .Sheets("Alle Rücklaufquote")
.PivotTables("PivotTable2").PivotCache.Refresh
.PivotTables("PivotTable2").PivotFields("WR").CurrentPage = WR(I)
End With
.Sheets(Array("Alle Marktranking", "Alle Rücklaufquote")).Copy
End With
Set wbneu = ActiveWorkbook
With wbneu
.ShowPivotTableFieldList = False
.Sheets("Alle Marktranking").Name = "Marktranking"
.Sheets("Alle Rücklaufquote").Name = "Rücklaufquote"
.SaveAs Filename:=Verz & "\" & UVerz & "\" & WR(I) & " " & t & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Dateiname = wbneu.FullName ' eingefügt!
.Close SaveChanges:=False
End With
'e-mailVersand per Lotus Notes
If MsgBox("Soll e-mail verschickt werden ? ", vbYesNo + vbQuestion, "e-mail-Versand") = vbYes Then
emailBetreff = InputBox("Betreff:", "e-mail-Versand", "Test Monatsbericht xx.2006")
emailText = "Sehr geehrte Damen und Herren, Liebe Kolleginnen und Kollegen" & Chr(10) & Chr(10) & _
"im Anhang erhalten Sie den Monatsbericht" & Chr(10) & Chr(10) & _
"mfg Ihr Rechnungswesen"
With wb1.Sheets("email")
' Textstring für Empfänger erzeugen, Einträge durch " ; " getrennt
emailAn = ""
Zeile = 3: Spalte = 4: SpalteWR = 1
Do Until IsEmpty(.Cells(Zeile, Spalte))
If .Cells(Zeile, SpalteWR) = WR(I) Then
If emailAn = "" Then
emailAn = .Cells(Zeile, Spalte).Value
Else
emailAn = emailAn & " ; " & .Cells(Zeile, Spalte).Value
End If
End If
Zeile = Zeile + 1
Loop
' Textstring für Kopie-Empfänger erzeugen, Einträge durch " ; " getrennt
emailKopie = ""
Zeile = 3: Spalte = 5
Do Until IsEmpty(.Cells(Zeile, Spalte))
If emailKopie = "" Then
emailKopie = .Cells(Zeile, Spalte).Value
Else
emailKopie = emailKopie & " ; " & .Cells(Zeile, Spalte).Value
End If
Zeile = Zeile + 1
Loop
' Textstring für Blindkopie-Empfänger erzeugen, Einträge durch " ; " getrennt
emailBKopie = ""
Zeile = 3: Spalte = 6
Do Until IsEmpty(.Cells(Zeile, Spalte))
If emailBKopie = "" Then
emailBKopie = .Cells(Zeile, Spalte).Value
Else
emailBKopie = emailBKopie & " ; " & .Cells(Zeile, Spalte).Value
End If
Zeile = Zeile + 1
Loop
End With
Call Lotus(Dateiname, emailBetreff, emailText, emailAn, emailKopie, emailBKopie)
End If
' Ende code für email-Versand
Next I
MsgBox "Die WR-Einzeldateien wurden durch die Masterdatei aktualisiert und anschließend im jeweiligen Unterverzeichnis abgelegt!" _
& vbCrLf & vbCrLf & "Das Programm wird jetzt beendet!"
ThisWorkbook.Saved = True
Application.Quit
End Sub
' Modul: mdlLotusNotes Typ = Allgemeines Modul
Private Sub Lotus(sAnhang As String, sBetrifft As String, sText As String, sEmpfang As String, sKopie As String, sBlindKopie As String)
' Hier sind VBA 6 Funktionalitäten (Split Replace) also in dieser Version ab E 2000
' Peter Haserodt 2004 - zusammengetragen aus dem Net und zusammengeschustert ;-)
' Für jeden auf eigene Gefahr und eigenem Verständis
' Die Variablen für Empfänger und Anhang sind richtig zu belegen
' sAnhang = "Ein Pfad zu einer Datei" ' Muss natürlich richtig gesetzt werden
Dim session As Object, db As Object, doc As Object, rtobject As Object
Dim rtitem As Object, AttachMe As Object, DerAnhang As Object
Dim user As String, server As String, mailfile As String
Dim vAn As Variant, vCopy As Variant, vBlind As Variant
On Error GoTo Fehler
' sText = "Test " & vbCrLf & "Zweite Zeile" ' Testtext, Haupttext der e-mail
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
' sEmpfang = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
' sBetrifft = "Mein Betreff" ' die Betreffzeile
' sKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
' sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
vAn = Split(sEmpfang, " ; ") ' Empfänger Array
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ") 'bcc Array
Set session = CreateObject("notes.notessession") ' Notes muss gestartet sein denke ich
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.getdatabase(server, mailfile)
Set doc = db.createdocument()
doc.Form = "Memo"
doc.SendTo = vAn ' an array
If Len(sKopie) > 0 Then doc.copyto = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' die Betreffzeile
Set rtitem = doc.CREATERICHTEXTITEM("body")
Call rtitem.APPENDTEXT(sText)
doc.SAVEMESSAGEONSEND = True
doc.PostedDate = Now
If sAnhang <> "" Then
Set AttachMe = doc.CREATERICHTEXTITEM("Attachment")
Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", sAnhang, "Attachment")
End If
Call doc.Send(False)
Aufraeumen:
On Error Resume Next
Set rtitem = Nothing
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub