title image


Smiley bin überglücklich .... und das am jahresanfang :=)))
hallo rainer,



vielen dank, der code funktioniert perfekt



hier noch einmal der code für interessierte :=)



Sub Excel_Serienmail_mit_mehreren_Anlagen_mit_Fehlermeldung_via_Outlook_Senden()

' von RAMSES 14.01.2003



'jeweils ab Zeile 2

'Spalte A = x oder leer (x wenn email verschickt werden soll

'Spalte B = Empfängeremail-Adresse

'Spalte C = Betrefftext je Empfänger

'Spalte D = Mailtext je Empfänger

'Spalte E = nach Versand Eintrag von Datum/Uhrzeit NT-Username und Computername

'Spalte F = Leer

'Spalte G = Verzeichnis+Dateiname (Max 10 Anlagen)



'Variablendefinition

Dim fs As Object, F As Object

Dim OutApp As Object, mail As Object

Dim i As Integer, y As Integer, Msg As Integer

Dim Nachricht As Variant

Dim AWS As String

Dim AnzEmpfänger As Integer

'Variablen füllen

'Filesystemobjekt erstellen

Set fs = CreateObject("Scripting.FileSystemObject")

'Hier die Anzahl Empfänger definieren



AnzEmpfänger = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row



'1. Fehlerprüfung

'Prüfen ob alle Inhalte vorhanden sind

'Wenn nicht wird das Makro abgebrochen

For i = 2 To AnzEmpfänger

If Cells(i, 2) = "" Then

Msg = MsgBox("Unvollständige Angaben beim Empfänger in Zeile " & i, vbCritical + vbOKOnly, "Abbruch")

Exit Sub

End If

Next i



'2. Fehlerprüfung

'Mit dem FilesystemObjekt wird zuerst die Existenz der Dateien geprüft. '

'Wenn eine nicht existiert wird das Makro abgebrochen

'Die Links auf die Anlagen liegen im Bereich G2 : G11



For y = 2 To ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row



'Wenn eine Zelle leer ist, wird aus der Schleife ausgestiegen

'ohne weitere Fehlerprüfung

If Cells(y, 7) = "" Then Exit For

If fs.fileexists(Cells(y, 7)) = False Then

Msg = MsgBox("Die Datei: " & Cells(y, 7) & " in G" & y & " exitstiert nicht !" & vbCrLf & "Der Sendevorgang an; " & Cells(i, 2) & " wird abgebrochen!", vbCritical + vbOKOnly, "Dateifehler")

Exit Sub

End If

Next y

'Sendevorgang einleiten



For i = 2 To AnzEmpfänger

Set OutApp = CreateObject("Outlook.Application")

Set Nachricht = OutApp.CreateItem(0)

On Error GoTo next_email



'Hier wird die zelle i in Spalte A auf den Wert X geprüft

'UCASE deshalb um Schreibfehler von Gross und klein zu vermeiden

If UCase(Cells(i, 1).Value) = "X" Then

'Trifft die Bedingung X zu wird der Mailversand eingeleitet

With Nachricht

.To = Cells(i, 2) '"irgendwer@irgendein-provider.de" SPALTE B

.Subject = Cells(i, 3) '"Betreffzeile Header" SPALTE C

.Body = Cells(i, 4) '"Sendetext" SPALTE D

'For y = 2 To 11

For y = 2 To ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row

AWS = Cells(y, 7)

'Wenn die Zelle / Variable leer ist wird diese Schleife abgebrochen

If AWS = "" Then Exit For

.Attachments.Add AWS

Next y

'Hier wird die Mail zuerst angezeigt

'.Display

'Hier wird die Mail gleich in den Postausgang gelegt

.Send

End With

'Variablen zurücksetzen

Set OutApp = Nothing 'CreateObject("Outlook.Application")

Set Nachricht = Nothing 'OutApp.CreateItem(0)

Application.Wait (Now + TimeValue("0:00:01"))

'versanddatum /-uhrzeit /-userid und computername in spalte e eintragen

Worksheets(ActiveSheet.Name).Cells(i, 5).Value = Date & " / " & Time & _

" / " & Environ("username") & " " & Environ("computername")

next_email:

End If

'Bedingung abgeschlossen

Next i

End Sub








Suche in meinen 22.000 Zitaten
mittels Volltextsuche ! HIER

Und hier in mein Excel-Tips

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: