Office: (Office 2010) E-Mail mit Outlook versenden

Jero84 · 21. Januar 2015

Hallo zusammen,

ich habe es jetzt geschafft mir einen eigenen Code zusammen zu basteln der bisher meine Erwartungen erfüllt.

Wen es interessiert folgend der Aufbau:
Es gibt ein Formular mit einem Listenfeld welches 4 Spalten einer Tabelle (ID, Nachname, Vorname, E-Mail) enthält.

Der Button cmd******** ruft folgenden Code ab:

Code:

Private Sub cmd********_Click()

Dim varSelectedItem As Variant
Dim strMailBCC As String
Dim check As Integer
Dim checkmail As String
Dim meldung As String

With Me.lstListe1
For Each varSelectedItem In .ItemsSelected

check = 0
checkmail = Me!lstListe1.Column(3, varSelectedItem)
check = InStr(checkmail, "@")

If check 0 Then
strMailBCC = strMailBCC & "; " & .Column(3, varSelectedItem)

Else
meldung = "Zeile :" & varSelectedItem & " Die E-Mail-Adresse ist nicht korrekt."
MsgBox (meldung)
GoTo Exit_cmd********_Click
End If

Next varSelectedItem
strMailBCC = Mid(strMailBCC, 3)

End With
DoCmd.SendObject , , acFormatHTML, "petra@porta.humbug", , strMailBCC

Exit_cmd********_Click:
Exit Sub

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dieser Code prüft zunächst ob in der Spalte E-Mail ein String mit dem Zeichen "@" (Grundvoraussetzung für eine E-Mail) enthalten ist.

Wenn alle markierten Zeilen fehlerfrei sind wird das E-Mail Programm gestartet und alle Adressen aus dem Listenfeld ins BCC eingetragen.

______________________________________

Sollte eine markierte Zeile im Listenfeld nicht korrekt sein wird eine Meldung ausgespuckt.

Und genau hier habe ich nun eine Frage!
Bisher schmeißt er mir die ID (Spalte 0) im Listenfeld aus welcher den Fehler enthält.

Es gibt doch bestimmt eine Möglichkeit geben statt der ID mir den Namen der Person anzuzeigen?

An der Stelle von:
Code:

"Zeile :" & varSelectedItem & " Die E-Mail-Adresse ist nicht korrekt."
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hätte ich gerne etwas ähnliches wie:
Code:

"Die E-Mail-Adresse von " & ?? varSelectedItem.column (2)?? & " ist nicht korrekt.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Leider ist es nur allzu logisch dass es so in dieser Form nicht funktionieren kann.

Kann mir hier bitte jemand von euch behilflich sein?

______________________________________

Meine zweite Frage wäre noch wie man Outlook dazu bringt die Signatur automatisch einzufügen.
Bisher muss ich es noch manuell machen, ist nicht weiter tragisch denn er macht es mit Logo (Teilerfolg)!

CptChaos · 21. Januar 2015

Ich habe mir vor geraumer Zeit eine Klasse für genau diese Zwecke erstellt. Die Klasse ist noch nicht soweit, dass ich sie als "fertig" bezeichnen und hier generell publizieren würde.

Du kannst Dir den folgenden Teil aber gerne anschauen, versuchen zu verstehen und vor allem zu verwenden. Grundsätzlich funktioniert er; diverse Unschärfen sind evtl. noch drin und kann ich (momentan) nicht beheben da ich dafür nicht die Zeit und Muße habe *wink.gif*

Code:

Option Compare Database
Option Explicit

' ___ Declares ___

' ___ Constants/Enums ___
Public Enum E_ERRORNUMBERS
E_NOOUTLOOK = vbObjectError + 500001
E_ATTACHMENTPATHNOTVALID = vbObjectError + 500002
E_ATTACHMENTNOTVALID = vbObjectError + 500003
E_NOOBJECT = vbObjectError + 500004
End Enum

Public Enum E_MailFormat
E_UNKNOWN = 0
E_PLAIN = 1
E_HTML = 2
E_RTF = 3
End Enum

Private Const C_MAPI As String = "MAPI"
Private Const C_MAILITEM As Long = 0
Private Const C_OUTBOX As Long = 4

' ___ Properties ___
Private application As Object
Private mapi As Object
Private mail As Object

Private m_Recipient As String
Private m_Cc As String
Private m_Bcc As String
Private m_Subject As String
Private m_Body As String
Private m_Category As String
Private m_Attachments As Variant
Private m_AttachmentPosition As Long
Private m_HTMLSignature As String

Public Property Get Recipient() As String
Recipient = m_Recipient
End Property
Public Property Let Recipient(ByVal Recipient As String)
m_Recipient = Recipient
End Property

Public Property Get Cc() As String
Cc = m_Cc
End Property
Public Property Let Cc(ByVal Cc As String)
m_Cc = Cc
End Property

Public Property Get Bcc() As String
Bcc = m_Bcc
End Property
Public Property Let Bcc(ByVal Bcc As String)
m_Bcc = Bcc
End Property

Public Property Get Subject() As String
Subject = m_Subject
End Property
Public Property Let Subject(ByVal Subject As String)
m_Subject = Subject
End Property

Public Property Get Body() As String
Body = m_Body
End Property
Public Property Let Body(ByVal Body As String)
m_Body = Body
End Property

Public Property Get Category() As String
Category = m_Category
End Property
Public Property Let Category(ByVal Category As String)
m_Category = Category
End Property

'ToDo: per Liste verwalten!
Public Property Get Attachments() As Variant
Attachments = m_Attachments
End Property
Public Property Let Attachments(ByVal Attachments As Variant)
m_Attachments = Attachments
End Property

Public Property Get AttachmentPosition() As Long
If m_AttachmentPosition = 0 Then
AttachmentPosition = Len(m_Body) + 1
Else
AttachmentPosition = m_AttachmentPosition + 1
End If
End Property
Public Property Let AttachmentPosition(ByVal AttachmentPosition As Long)
m_AttachmentPosition = AttachmentPosition
End Property

Public Property Get HTMLSignature() As String
HTMLSignature = m_HTMLSignature
End Property
Public Property Let HTMLSignature(ByVal HTMLSignature As String)
m_HTMLSignature = HTMLSignature
End Property

' ___ Initialize/Terminate ___
Private Sub Class_Initialize()
On Error GoTo Exit_Class_Initialize

Set application = CreateObject("Outlook.Application")
Set mapi = application.GetNamespace(C_MAPI)
Set mail = mapi.GetDefaultfolder(C_OUTBOX).Items.Add(C_MAILITEM)

Exit_Class_Initialize:
Dim errMsg As String
Select Case Err.Number
Case 0
Case 429
GoSub CleanUp
errMsg = "Couldn't create Outlook.Application. Please verify the installation of Microsoft Outlook"
Err.Raise E_NOOUTLOOK, "Outlook_MailObject", errMsg
Case Else
GoSub CleanUp
Err.Raise Err.Number, Err.Source & vbNewLine & vbTab & "Outlook_MailObject.Class_Initialize", Err.Description
End Select
GoSub CleanUp
Exit Sub

CleanUp:
Return
End Sub

Private Sub Class_Terminate()
Set mail = Nothing
Set mapi = Nothing
Set application = Nothing
End Sub

' ___ Public Members ___
Public Sub SendEMail(ByVal format As E_MailFormat, _
Optional ByVal useDefaultSignature As Boolean = True, Optional ByVal showMailWindow As Boolean = False)
******** format, useDefaultSignature, showMailWindow
End Sub

Public Sub SendHTMLMail(Optional ByVal useDefaultSignature As Boolean = True, Optional ByVal showMailWindow As Boolean = False)
******** E_HTML, useDefaultSignature, showMailWindow
End Sub

Public Sub SendRTFMail(Optional ByVal useDefaultSignature As Boolean = True, Optional ByVal showMailWindow As Boolean = False)
******** E_RTF, useDefaultSignature, showMailWindow
End Sub

Public Sub SendTEXTMail(Optional ByVal useDefaultSignature As Boolean = True, Optional ByVal showMailWindow As Boolean = False)
******** E_PLAIN, useDefaultSignature, showMailWindow
End Sub

' ___ Private Members ___
Private Sub ********(ByVal format As E_MailFormat, _
Optional ByVal useDefaultSignature As Boolean = True, Optional ByVal showMailWindow As Boolean = False)

Dim attachmentCount As Long
With mail
.To = m_Recipient
.Cc = m_Cc
.Bcc = m_Bcc
.Subject = m_Subject
.Categories = m_Category
.BodyFormat = format

If useDefaultSignature Then
Select Case format
Case olFormatHTML
SetHTMLSignature
.HTMLBody = ConvertToHTML(m_Body) & HTMLSignature
Case Else
.GetInspector
.Body = m_Body & .Body
End Select
Else
.Body = m_Body
End If

If IsArray(m_Attachments) Then
For attachmentCount = 0 To UBound(m_Attachments)
If Len(m_Attachments(attachmentCount)) > 0 Then
mail.Attachments.Add m_Attachments(attachmentCount), 1, AttachmentPosition
End If
Next attachmentCount
ElseIf Len(m_Attachments) > 0 Then
mail.Attachments.Add m_Attachments, 1, AttachmentPosition
End If

If showMailWindow Then
.Display
Else
.Send
End If

End With

End Sub

Private Function ConvertToHTML(ByVal valueToConvert As String) As String
ConvertToHTML = "" & Replace(valueToConvert, Chr(13), "") & ""
End Function

Private Sub SetHTMLSignature()
On Error GoTo Exit_SetHTMLSignature

Dim word As Object
Dim fso As Object
Dim stream As Object
Dim className As String
Dim wordIsExclusive As Boolean
Dim defaultSignature As String
Dim signatureFile As String

If Len(m_HTMLSignature) = 0 Then

className = "Word.Application"
On Error Resume Next
Set word = GetObject(, className)
On Error GoTo Exit_SetHTMLSignature

If word Is Nothing Then
Set word = CreateObject("Word.Application")
wordIsExclusive = True
End If

defaultSignature = word.EmailOptions.EmailSignature.NewMessageSignature

Select Case defaultSignature
Case "(ohne)", "(none)"
m_HTMLSignature = vbNullString
Case Else
signatureFile = Environ("appdata") & "\Microsoft\Signatures\" & defaultSignature & ".htm"
If Len(Dir(signatureFile, vbHidden Or vbReadOnly Or vbSystem Or vbArchive)) > 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set stream = fso.GetFile(signatureFile).OpenAsTextStream(1, -2)
m_HTMLSignature = stream.ReadAll
stream.Close
End If
End Select

End If

Exit_SetHTMLSignature:
Dim errMsg As String
Select Case Err.Number
Case 0
Case 429
GoSub CleanUp
Err.Raise E_NOOBJECT, "Outlook_MailObject", Err.Description
Case Else
GoSub CleanUp
Err.Raise Err.Number, Err.Source & vbNewLine & vbTab & "Outlook_MailObject.SetHTMLSignature", Err.Description
End Select
GoSub CleanUp
Exit Sub

CleanUp:
If wordIsExclusive Then
word.Quit
Set word = Nothing
End If

Set stream = Nothing
Set fso = Nothing
Return

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

-> Abspeichern als Klassenmodul unter dem Namen OutlookMailObject!

Der Aufruf erfolgt dann entweder direkt über eine Instanz der Klasse und befüllen der Properties ähnlich folgendem Code: Code:

Public Sub TestMailClass()
On Error GoTo TestMailClass_Err

Dim myOLMailObject As OutlookMailObject
Dim attPath As Variant

'Ein Attachment
'attPath = "C:\Temp\test.txt"
'Mehrere Attachments
'attPath = Split("C:\Temp\test.txt|C:\Temp\test1.txt|C:\Temp\test2.txt", "|")

Set myOLMailObject = New OutlookMailObject

With myOLMailObject
.Recipient = "p525874"
.Category = "OutlookHelper"
.Subject = "Testbetreff"
.Body = "Testtext Testtext Testtext Testtext Testtext Testtext Testtext Testtext Testtext "
.Attachments = attPath
.SendRTFMail True, True
End With

On Error GoTo 0

TestMailClass_End:
Set myOLMailObject = Nothing
Exit Sub

TestMailClass_Err:
Dim errMsg As String
errMsg = "Error No '" & Err.Number & "' in '" & Err.Source & "' occurred." & vbNewLine & _
"Error Description: " & Err.Description

MsgBox errMsg, vbCritical, "TestMailClass"
Resume TestMailClass_End

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

el_gomero · 21. Januar 2015

Moin,

Hätte ich gerne etwas ähnliches wie:
Code:

"Die E-Mail-Adresse von " & ?? varSelectedItem.column (2)?? & " ist nicht korrekt.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Probier mal:
Code:

strMeldung = "Die E-Mail-Adresse von " & Me!LstListe1(varSelectedItem).column(2) & " ist nicht korrekt."
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dein Code verwendet teils ungarische Notation, teils nicht - besser wäre imho:
Code:

Private Sub cmd********_Click()

Dim lngSelectedItem As Long, intCheck As Integer
Dim strMailBCC As String, strCheckmail As String, strMeldung As String

With Me.lstListe1
For Each lngSelectedItemIn .ItemsSelected

intCheck = 0
strCheckmail = Me!lstListe1.Column(3, lngSelectedItem)
intCheck = InStr(strCheckmail, "@")

If intCheck 0 Then
strMailBCC = strMailBCC & "; " & .Column(3, lngSelectedItem)

Else
strMeldung = "Zeile :" & lngSelectedItem& " Die E-Mail-Adresse ist nicht korrekt."
MsgBox (strMeldung)
GoTo Exit_cmd********_Click
End If

Next lngSelectedItem
strMailBCC = Mid(strMailBCC, 3)

End With
DoCmd.SendObject , , acFormatHTML, "petra@porta.humbug", , strMailBCC

Exit_cmd********_Click:
Exit Sub

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Jero84 · 22. Januar 2015

Danke euch beiden recht herzlich!

Ich werde mich direkt mal durcharbeiten. *Smilie

Code:

"Die E-Mail-Adresse von " & Me!LstListe1(varSelectedItem).column(2) & " ist nicht korrekt."
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Das funktioniert leider nicht. Bekomme dann eine Fehlermeldung mit Let und Get fehlerhaft.

Office: (Office 2010) E-Mail mit Outlook versenden

E-Mail mit Outlook versenden

E-Mail mit Outlook versenden

E-Mail mit Outlook versenden

E-Mail mit Outlook versenden - Similar Threads - Mail Outlook versenden

E-Mails versenden geht nicht

Office365 / Outlook: Fehlermeldung beim Schreiben/Versenden von Mails

Versenden E-Mail aus Excel Liste via VBA & Outlook

Das Versenden von E-Mails über verbundene Konten von Outlook.com aus der Outlook-App ist ...

Outlook 2016 - Kann keine Mails versenden

Alias beim versenden von Mails verwenden - GMX Account !

Frage: Terminplanung aus Excel - Termine in outlook automatisiert versenden?