Hilfe: E-Mail senden in Excel, ABER ...

Sub MailListFile() Dim olApp As Object Dim wsShell Dim iCounter As Integer Dim aws As String If MsgBox("Soll der automatische eMail Versand gestartet werden ?", _ vbYesNo + vbQuestion, "Frage") = vbNo Then Exit Sub For iCounter = 3 To Cells(Rows.Count, 2).End(xlUp).Row aws = Cells(iCounter, 7) Set olApp = CreateObject("Outlook.Application") With olApp.CreateItem(0) .To = Cells(iCounter, 2) .CC = Cells(iCounter, 3) .BCC = Cells(iCounter, 4) .Subject = Cells(iCounter, 5) .Body = Cells(iCounter, 6) If aws "" Then _ .Attachments.Add aws .Display Set wsShell = CreateObject("WScript.Shell") wsShell.AppActivate olApp wsShell.SendKeys "%s" Set wsShell = Nothing Application.Wait (Now + TimeValue("0:00:05")) 'Wartezeit 10 sek End With Next iCounter Set olApp = Nothing MsgBox "eMail Versand abgeschlossen" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
hier mal ein erster Ansatz,
es sollten nach jedem Senden oder Schließen alle Mailfenster
nacheinander aufgerufen werden...

Option Explicit
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds As Long)
Private Declare Function SetTimer Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal nIDEvent As Long) As Long
Private Const GC_CLASSNAMEMSOUTLOOK = "rctrl_renwnd32"
Private Const INSPEC_CAP As String = " - Nachricht (HTML) " ''" - Message (HTML) " bei engl. Excel-Version
Private Const olByValue = 1
Private Const olMailItem = 0
Private objOLApp As Object
Private blnExit As Boolean
Private blnExitTimer As Boolean
Private lngCount As Long
Private lngArrRow() As Long
Private strCaption As String
Public Sub prcMailListFile() 'hier aufrufen...
Dim lngIndex As Long
Dim strPath As String
Dim objCell As Range
If Not blnExit Then
  blnExit = Not blnExit
  If MsgBox("Soll der automatische eMail Versand gestartet werden ?", _
    vbYesNo + vbQuestion, "Frage") = vbNo Then
    blnExit = Not blnExit
    Exit Sub
  End If
  With Worksheets("Tabelle1")
      If Intersect(.Range(.Cells(1, 1), _
        .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
        .Cells(1, .Columns.Count).End(xlToLeft).Column)), Selection) Is Nothing Then
        MsgBox "Die activen Zellen befinden sich nicht in der CommandZone!", _
        vbExclamation, "NoCommand"
        blnExit = Not blnExit
        Exit Sub
      End If
  End With
  Set objOLApp = CreateObject(Class:="Outlook.Application")
  ReDim lngArrRow(Selection.Count - 1) As Long
  For Each objCell In Selection
     lngIndex = lngIndex + 1
     lngArrRow(lngIndex - 1) = objCell.Row
  Next
  strPath = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 8)
  With objOLApp.CreateItem(olMailItem)
      .To = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 1)
      .CC = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 2)
      .BCC = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 3)
      .Subject = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 4)
      strCaption = .Subject & INSPEC_CAP
      .Body = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 7)
      If strPath <> "" Then _
         .Attachments.Add strPath, olByValue
     .Display
  End With
  Call prcStartTimer
End If
End Sub
Private Sub prcStartTimer()
SetTimer Application.hwnd, 0&, 200&, AddressOf TimerProc
End Sub
Private Sub prcStopTimer()
KillTimer Application.hwnd, 0&
End Sub
Private Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
If Not blnExitTimer Then
  If FindWindow(GC_CLASSNAMEMSOUTLOOK, strCaption) = 0 And lngCount < UBound(lngArrRow) Then
    blnExitTimer = Not blnExitTimer
    DoEvents
    Sleep 200&
    Set objOLApp = CreateObject(Class:="Outlook.Application")
    Call prcDisplay
  ElseIf FindWindow(GC_CLASSNAMEMSOUTLOOK, strCaption) = 0 And lngCount >= UBound(lngArrRow) Then
    Call prcStopTimer
    Set objOLApp = Nothing
    MsgBox "eMail Versand abgeschlossen", _
      vbInformation, "E-Mail delivery successfully completed"
    lngCount = 0
    blnExit = Not blnExit
  End If
End If
End Sub
Private Sub prcDisplay()
Dim strPath As String
lngCount = lngCount + 1
strPath = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 8)
With objOLApp.CreateItem(olMailItem)
    .To = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 1)
    .CC = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 2)
    .BCC = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 3)
    .Subject = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 4)
    strCaption = .Subject & INSPEC_CAP
    .Body = Worksheets("Tabelle1").Cells(lngArrRow(lngCount), 7)
    If strPath <> "" Then _
      .Attachments.Add strPath, olByValue
    .Display
    If blnExitTimer Then _
      blnExitTimer = Not blnExitTimer
End With
End Sub

Zu Infoquellen:
natürlich neben den hier vorhandenen Sparten (z.B. Excel-FAQ)
bieten
http://www.online-excel.de/ Grundlagentutorials(s. Outlook & Excel)
http://www.office-loesung.de/ Tipps und Tricks bes. von Nepumuk & Isabelle
http://vbanet.blogspot.de komplette Codevorlagen mit sehr guten Kommentierungen (Case)
Gruß,

Hallo Sandra,
genau diese Problemstellung beschäftigt mich derzeit auch, also zunächst vielen Dank für Deine Fragen, die bereits ein Stück Antwort für mich bereithalten.
Ad 3: daß die ganze Liste gesendet wird stimmt nicht, nur 3 und 4, weil Du erst ab 3 zählst. Aber egal: solange Du mit einer FOR-Schleife hantierst, werden natürlich "alle" angemailt.
Abhilfe: Du ermittelst die Zeile, in der irgendeine Zelle aktiv ist:
iCounter = ActiveCell.Row
So wird die mail nur an Empfänger in DIESER Zeile gesandt.
Ad 1: Die Nummerierung im Makro stimmt nicht mit der Tabelle überein; vermutlich hast Du die Spalte A gelöscht, bevor Du sie hochgeladen hast.
Wenn man Zeichenketten zusammenfügt, geht das (wie in Deinem Text) mit & VBA kann aber auch + und konvertiert Zahlen automatisch in Zeichen (googel mal nach dem Stichwort concatenation).
Man hat ja Platz ohne Ende, ich würde "rechts" Spalten mit Namen (Ansprechpartner) usw. einfügen, damit das schöner aussieht, außerdem kannst Du dann dort alle Texthäppchen mit =Verketten() zusammenfügen und in VBA etwa aus Spalte K abgreifen.
Ad 2: die Spalte kommt mir ein bißchen doppelt gemoppelt vor; kannst Du das bitte ein bißchen ausführen?
Frohes Schaffen noch,
Michael

Beliebteste Forumthreads (12 Monate)

Hilfe: E-Mail senden in Excel, ABER ...

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Hilfe: E-Mail senden in Excel, ABER ...

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread