E-mail beantworten inkl. Anhang

Private Sub CommandButton2_Click() Dim DateiName As String Dim Pfad As String Dim lw_pfad As String Dim strFolder As String Dim lngRetun As Long Dim blnReturn As Boolean Dim i As Long, Zelle As Range Dim Zeichen As String Dim myAnswer As Object With Worksheets("Angebot") For Each Zelle In .Range("T70") For i = 1 To Len(Zelle.Text) Zeichen = Mid(Zelle.Text, i, 1) Select Case Zeichen Case "/" Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i) Case "\" Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i) Case ":" Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i) Case "*" Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i) Case "?" Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i) Case ">" Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i) Case "

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub TestMail() DateiName = Sheets("Angebot").Range("t70") & ".pdf" Sheets("Angebot").Range("C55:n111").ExportAsFixedFormat Type:=xlTypePDF, Filename:=DateiName, _ Quality:=xlqualitystandart, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Dim olApp As Object ', AktMail As Object, Dim myAnswer As Object Set olApp = CreateObject("Outlook.Application") 'OutlookVerweis If Not olApp.ActiveInspector Is Nothing Then 'Pruefung auf offene Mail With olApp.ActiveInspector.CurrentItem() Set myAnswer = .ReplyAll 'allen Antworten-Verweis .Close False 'Aktuelle Mail schliessen End With With myAnswer .SentOnBehalfOfName = "xxxxxxx" 'senden von Konto .Subject = "Betreff" 'Betreff NEU schreiben? ohne _ diese Zeile AW: Original-Betreff .htmlbody = "Text" & .htmlbody 'htmlBody ERGAENZEN ' .htmlbody = "Text" 'htmlbody beschreiben .Display 'anzeigen End With Else MsgBox "keine offene Mail" End If Set myAnswer = Nothing Set olApp = Nothing End Sub

Hallo Kai,
ein Beispiel:

Option Explicit

Private Const olMail As Long = 43

Public Sub Test()
    Dim objOutlook As Object, objInspectors As Object
    Dim objItem As Object
    Dim blnFound As Boolean
    On Error Resume Next
    Set objOutlook = GetObject(Class:="Outlook.Application")
    If Err.Number <> 0 Then
        Call MsgBox("Kein offenes Outlook gefunden.", vbCritical, "Programmabbruch")
    Else
        Set objInspectors = objOutlook.Inspectors
        For Each objItem In objInspectors
            If objItem.CurrentItem.Class = olMail Then
                blnFound = True
                Call MsgBox(objItem.CurrentItem.SenderEmailAddress)
                Call MsgBox(objItem.CurrentItem.CC)
                Call MsgBox(objItem.CurrentItem.Subject)
            End If
        Next
        If Not blnFound Then _
            Call MsgBox("Keine offene Mail gefunden.", vbCritical, "Programmabbruch")
    End If
    Set objItem = Nothing
    Set objInspectors = Nothing
    Set objOutlook = Nothing
End Sub

Gruß
Nepumuk

Option Explicit Private Const olMail As Long = 43 Public Sub Test() Dim objOutlook As Object, objInspectors As Object Dim objItem As Object, objMail As Object Dim blnFound As Boolean Dim strPath As String On Error Resume Next Set objOutlook = GetObject(Class:="Outlook.Application") If Err.Number 0 Then Call MsgBox("Kein offenes Outlook gefunden.", vbCritical, "Programmabbruch") Else On Error GoTo 0 Set objInspectors = objOutlook.Inspectors For Each objItem In objInspectors If objItem.CurrentItem.Class = olMail Then blnFound = True strPath = ThisWorkbook.Path & "\" & Worksheets("Angebot").Range("T70") & ".pdf" Call Worksheets("Angebot").Range("C55:N111").ExportAsFixedFormat( _ Type:=xlTypePDF, Filename:=strPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False) Set objMail = objItem.CurrentItem With objMail .SentOnBehalfOfName = "xxxxxxx" .Subject = "Betreff" .HtmlBody = "Text" & .HtmlBody Call .Attachments.Add(strPath) .Display End With End If Next If Not blnFound Then _ Call MsgBox("Keine offene Mail gefunden.", vbCritical, "Programmabbruch") End If Set objItem = Nothing Set objInspectors = Nothing Set objOutlook = Nothing End Sub

Hallo zusammen,
hab es hinbekommen.
hab noch ein Problem mit dem Absatz beim smailtext.
Gibts da eine Trick? hab schon sämtliche (Chr(13)etc. ausprobiert)

Private Sub CommandButton2_Click()
Dim DateiName As String
Dim Pfad As String
Dim lw_pfad As String
Dim strFolder As String
Dim lngRetun As Long
Dim blnReturn As Boolean
Dim i As Long, Zelle As Range
Dim Zeichen As String
On Error Resume Next
Set objOutlook = GetObject(Class:="Outlook.Application")
If Err.Number  0 Then
Call MsgBox("Kein offenes Outlook gefunden.", vbCritical, "Programmabbruch")
Else
On Error GoTo 0
With Worksheets("Angebot")
For Each Zelle In .Range("T70")
For i = 1 To Len(Zelle.Text)
Zeichen = Mid(Zelle.Text, i, 1)
Select Case Zeichen
Case "/"
Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "\"
Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i)
Case ":"
Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "*"
Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "?"
Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i)
Case ">"
Zelle.Value = Left(Zelle.Text, i - 1) & "-" & Right(Zelle.Text, Len(Zelle.Text) - i)
Case "

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

123 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

E-mail beantworten inkl. Anhang

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

123 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread