Automatisches Senden einer E-Mail per Outlook


                            Hallo Marc,

teste mal:


Option Explicit

Public Sub SucheundFinden()
    
    Dim objWorksheet As Worksheet
    Dim objCell As Range
    
    For Each objWorksheet In ThisWorkbook.Worksheets
        With objWorksheet
            For Each objCell In .Range("A1:C3")
                If objCell.Interior.Color = vbRed Then
                    Call .Range("A2:E20").CopyPicture
                    Call SendMail(.Name, .Cells(1, 1).Text)
                    Exit For
                End If
            Next
        End With
    Next
End Sub

Private Sub SendMail( _
        ByVal pvstrWorksheetName As String, _
        ByVal pvstrTo As String)
    
    Dim objOutlook As Object, objMail As Object, objWord As Object
    
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    With objMail
        .BodyFormat = 2
        .To = pvstrTo
        .Subject = "Fehler im " & pvstrWorksheetName
        Call .Display
        Set objWord = .GetInspector.WordEditor.Application
        Call objWord.Selection.Paste
        '        .Send 'direkt senden
    End With
    
    Set objWord = Nothing
    Set objMail = Nothing
    Set objOutlook = Nothing
    
End Sub


Gruß

Nepumuk

Sub SucheundFinden() Dim i As Integer Dim n As Integer Dim Zelle As Range n = ActiveWorkbook.Worksheets.Count For i = 1 To n With Worksheets(i) For Each Zelle In Range("A1:C3") If Zelle.Interior.Color = RGB(255, 0, 0) Then Worksheets(i).Select Range("A2:E20").Select Selection.Copy Mail End If Next End With Next End Sub

Sub Mail() Dim objOutlook As Object Dim objMail As Object Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) With objMail .To = ActiveSheet.Range("A1") .Subject = "Fehler im " & ActiveSheet.Name Application.SendKeys ("^v") .Send End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Marc,
teste mal so:

Option Explicit

Public Sub SucheundFinden()
    
    Dim objWorksheet As Worksheet
    Dim objCell As Range
    
    For Each objWorksheet In ThisWorkbook.Worksheets
        With objWorksheet
            For Each objCell In .Range("A1:C3")
                If objCell.Interior.Color = vbRed Then
                    Call SendMail(.Name, "A2:E20", .Cells(1, 1).Text)
                    Exit For
                End If
            Next
        End With
    Next
End Sub

Private Sub SendMail( _
        ByVal pvstrWorksheetName As String, _
        ByVal pvstrRangeAddress As String, _
        ByVal pvstrTo As String)
    
    Dim objOutlook As Object, objMail As Object
    
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    
    With objMail
        .To = pvstrTo
        .Subject = "Fehler im " & pvstrWorksheetName
        .HTMLBody = RangeToHtml(pvstrWorksheetName, pvstrRangeAddress)
        .Display 'zum testen
        '        .Send 'direkt senden
    End With
    
    Set objMail = Nothing
    Set objOutlook = Nothing
    
End Sub

Private Function RangeToHtml( _
        ByVal pvstrWorksheetName As String, _
        ByVal pvstrRangeAddress As String) As String
    
    Const FOR_READING As Long = 1
    Const TRISTATE_USEDEFAULT As Long = -2
    
    Dim objFilesytem As Object, objTextstream As Object
    Dim objPublishObject As PublishObject
    Dim strFilename As String, strTempText As String
    
    strFilename = Environ$("TEMP") & "\" & _
        Format$(Now, "dd-mm-yy_hh-mm-ss") & ".htm"
    
    Set objPublishObject = ThisWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=strFilename, _
        Sheet:=pvstrWorksheetName, _
        Source:=pvstrRangeAddress, _
        HtmlType:=xlHtmlStatic)
    Call objPublishObject.Publish(Create:=True)
    
    Set objFilesytem = CreateObject("Scripting.FileSystemObject")
    Set objTextstream = objFilesytem.GetFile( _
        strFilename).OpenAsTextStream(FOR_READING, TRISTATE_USEDEFAULT)
    
    strTempText = objTextstream.ReadAll
    Call objTextstream.Close
    
    RangeToHtml = Replace(strTempText, "align=center x:publishsource=", _
        "align=left x:publishsource=")
    
    Set objPublishObject = Nothing
    Set objTextstream = Nothing
    Set objFilesytem = Nothing
    
    Call Kill(PathName:=strFilename)
    
End Function


Gruß

Nepumuk

Beliebteste Forumthreads (12 Monate)

Automatisches Senden einer E-Mail per Outlook

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Automatisches Senden einer E-Mail per Outlook

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread