Email aus Excel - Signatur ohne Bilder

Sub RaimundMail()

    Dim OlApp As Object

    Dim xlNewFileName As String

    Dim tm As String

    Dim ws As Worksheet

    Dim lastRow As Long

    Dim foundCell As Range

    Dim strSignature As String

    Dim strPath As String

    Dim strPathBild As String

    tm = Format(Time, "Short Time")

    

    Set OlApp = CreateObject("Outlook.Application")

    

    strPath = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\"

    

    strSignature = "Raimund.htm"

    Dim signatureFile As String

    signatureFile = strPath & "Raimund.htm"

    

    If Dir(signatureFile) > "" Then

        Dim fileNumber As Integer

        fileNumber = FreeFile

        Open signatureFile For Input As fileNumber

        strSignature = Input$(LOF(fileNumber), fileNumber)

        Close fileNumber

    End If

    

    strPathBild = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\"

    

 

    

    For Each ws In ThisWorkbook.Worksheets

        If ws.Visible = xlSheetVisible Then

            ws.Activate

            

            Set foundCell = ws.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious)

            

            If Not foundCell Is Nothing Then

                lastRow = foundCell.Row

            Else

                GoTo NextSheet

            End If

            

            With ws.PageSetup

                .PrintArea = "A1:G" & lastRow

                .Orientation = xlPortrait

            End With

            

            Range("B2").Select

            

            xlNewFileName = Environ("USERPROFILE") & "\Documents\" & ws.Name & ".pdf"

            ws.Range("A:G").ExportAsFixedFormat Type:=xlTypePDF, Filename:=xlNewFileName, _

                Quality:=xlQualityStandard, IncludeDocProperties:=True, _

                IgnorePrintAreas:=True, OpenAfterPublish:=False

            

            Dim olMail As Object

            Set olMail = OlApp.CreateItem(0)

            

            With olMail

                If tm  "12:00" Then

                    .HTMLBody = "Good Morning.

Attached you will find your report.

"

                Else

                    .HTMLBody = "Good Afternoon.

Attached you will find your report.

"

                End If

                

                If ActiveCell.Value = "ABC" Or ActiveCell.Value = "DEF" Then

                    .To = "raimund@web.de "

                End If

                



                

                ' HTMLBody erstellen und die Bilder einbetten

                Dim completeBody As String

                completeBody = .HTMLBody & strSignature & ""

                

                .HTMLBody = completeBody

                

                .Attachments.Add xlNewFileName

                .Subject = " Report - " & ws.Range("B2").Value & " in " & Format(DateAdd("m", -1, Now), "MMMM-YYYY")

                

                On Error Resume Next

                .Send

                On Error GoTo 0

            End With

            

NextSheet:

        End If

    Next ws

    

    ThisWorkbook.Worksheets("Wheelie Bins").Activate

    ThisWorkbook.Worksheets("Wheelie Bins").Range("C3").Select

    

    Set OlApp = Nothing

    Set olMail = Nothing

End Sub