Makro Email versenden an ExcelKontakte

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub MailProgrammÖffnen() On Error Resume Next Set olApp = CreateObject("Outlook.Application") With olApp.CreateItem(0) .display .To = ? .cc="test@test.de;test2@test.de" 'Optional Kopie an .bcc="test@test.de;test2@test.de" 'Optional Bliendkopie an .Subject = "Guten Tag" .Body = "Hallo!" & vbCrLf & vbCrLf & "Gruß," & " " & Application.UserName End With End Sub

Hallo Kiki,
in ein allgemeines Modul. (Tabellenname anpassen!)

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub collectMailAddresses()
Dim rng As Range
Dim strAddress() As String, strFind() As String, strFirst As String, strTo As String
Dim varTmp As Variant
Dim lngI As Long, lngN As Long, lngM

With Sheets("Tabelle1") 'Tabellenname anpassen!
  Set rng = .UsedRange.Find(What:="@", LookIn:=xlValues, LookAt:=xlPart, _
    MatchCase:=False, SearchFormat:=False)
  'Zellen mit Mailadressen ermitteln
  If Not rng Is Nothing Then
    strFirst = rng.Address
    Do
      Redim Preserve strFind(lngI)
      strFind(lngI) = rng.Text
      lngI = lngI + 1
      Set rng = .UsedRange.FindNext(rng)
    Loop While Not rng Is Nothing And rng.Address <> strFirst
  End If
  'Mailadressen extrahieren und prüfen
  If lngI > 0 Then
    For lngI = 0 To UBound(strFind)
      varTmp = Split(strFind(lngI), " ")
      For lngN = 0 To UBound(varTmp)
        If InStr(1, varTmp(lngN), "@") > 0 Then
          If IsValidMailAddress(varTmp(lngN)) Then
            Redim Preserve strAddress(lngM)
            strAddress(lngM) = varTmp(lngN)
            lngM = lngM + 1
          End If
        End If
      Next
    Next
  End If
  'Mail vesenden
  If lngM > 0 Then
    strTo = Join(strAddress, ";")
    Call sendMailOL(strTo)
  Else
    MsgBox "Keine Mailadressen gefunden!", vbInformation
  End If
End With

Set rng = Nothing
End Sub

Sub sendMailOL(Recipient As String)
Dim objOL As Object, objMail As Object

Set objOL = CreateObject("Outlook.Application")
Set objMail = objOL.CreateItem(0)


On Error Resume Next
With objMail
  .To = Recipient
  .CC = "test@test.de;test2@test.de"  'Optional Kopie an
  .BCC = "test@test.de;test2@test.de" 'Optional Bliendkopie an
  .Subject = "Guten Tag"
  .Body = "Hallo!" & vbCrLf & vbCrLf & "Gruß," & " " & Application.UserName
  '.Attachments.Add ("D:\yourFile")
  .Send   '.Display
End With
On Error GoTo 0

Set objMail = Nothing
Set objOL = Nothing
End Sub

Private Function IsValidMailAddress(ByVal strAddress As String) As Boolean
Dim oRegExp As Object
Set oRegExp = CreateObject("vbscript.regexp")

With oRegExp
  .Pattern = "[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+/=?^_`{|" & _
    "}~-]+)*@(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:" & _
    "[a-z0-9-]*[a-z0-9])?"
  
  .IgnoreCase = True
  
  IsValidMailAddress = .test(strAddress)
End With

Set oRegExp = Nothing

End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Makro Email versenden an ExcelKontakte

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro Email versenden an ExcelKontakte

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread