Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
2000to2004
2000to2004
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Anzeige
Inhaltsverzeichnis

Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig

Forumthread: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig

Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
11.01.2025 12:19:33
Karsten Jung
Hallo zusammen,

ich muss eine Einsatzplanung per VBA als Mail verschicken.
Bisher hat das super geklappt mit folgenden Makro: 
        'Tabellenbereich einfügen'

        Dim WSh1 As Worksheet, WSh2 As Worksheet

        Dim sBer As String

        ThisWorkbook.Worksheets("E-Mail").Range("A1:H76").Copy                          ' Bereich kopieren

        With CreateObject("Outlook.Application").CreateItem(0)

            .BodyFormat = 3                           ' 2=HTML-Format

            .Subject = "Einsatzplanung für den Zeitraum " & Format(DTPicker1, "dd.mm.yy") & " bis " & Format(DTPicker1 + 6, "dd.mm.yy")                     ' Betreff

            .Display

            .To = "k.j@*****.**"

            .GetInspector.WordEditor.Range.Paste      ' Bereich in Mail einfügen

            Application.CutCopyMode = False

            .Send

        End With

Jetzt wurden die PC`s in der Firma umgestellt und wir arbeiten aus Citrix Servern mit Office und dort ist dann natürlich kein Outlook aktiv.
Wenn der o.g. Makro startet, öffnet sich eine Online-Outlook Variante, wo dann aber Pop-Ups kommen, die verlangen, diese Aktion freizugeben.
Bei der zweiten Abfrage, wenn die den Datenbereich einfüge, sogar mit eine Timer bevor man klicken kann.

Dafür gibt es bestimmt keine Umgehung, oder?

Deshalb habe ich mich mit den CDO.message beschäftigt und die Tabelle soweit auch nachgebaut bekommen.
Was extrem kompliziert war. (vielleicht habe ich es auch nur zu kompliziert gebaut, keine Ahnung) 


Sub E_Mail_erstellen

        ThisWorkbook.Worksheets("AR").Select

        text = ""

        Überschrift = "Einsatzplanung für den " & ThisWorkbook.Worksheets("AR").Cells(1, 7)

        AB = "AR"

        'Überschrift

        text = text & "
"        'Tabelle definieren, Rahmen um Tabelle"

        text = text & "" 'Überschrift

        For Zeile = 1 To 45

            If Zeile = 25 Then Zeile = 42

            text = text & "" 'neue Zeile

            If Zeile = 44 Then

                text = text & ""

                GoTo Zeile1a

            End If

            If Zeile = 42 Then

                text = text & ""

            Else

                If Zeile > 1 Then

                    If Zeile > 43 And Zeile > 45 Then

                        Call Farbe3(Zeile, AB, text, 1, True)

                    End If

                Else

                    text = text & ""

                End If

            End If

Zeile1a:

            If ThisWorkbook.Worksheets(AB).Cells(Zeile, 2) = "0" Then

                text = text & ""

            Else

                If Zeile = 1 Then

                    text = text & ""

                Else

                    Call Farbe3(Zeile, AB, text, 2, False)

                End If

            End If

            If ThisWorkbook.Worksheets(AB).Cells(Zeile, 3) = "0" Then

                text = text & ""

            Else

                If Zeile = 1 Then

                    text = text & ""

                Else

                    Call Farbe3(Zeile, AB, text, 3, False)

                End If

            End If

            If ThisWorkbook.Worksheets(AB).Cells(Zeile, 4) = "0" Then

                text = text & ""

            Else

                If Zeile = 6 Or Zeile = 7 Then

                    If Zeile = 6 Then text = text & ""

                Else

                    If Zeile = 1 Then

                        text = text & ""

                    Else

                        Call Farbe3(Zeile, AB, text, 4, False)

                    End If

                End If

            End If

            If ThisWorkbook.Worksheets(AB).Cells(Zeile, 5) = "0" Then

                text = text & ""

            Else

                If Zeile > 3 And Zeile  6 Or Zeile > 7 And Zeile  17 Or Zeile > 22 And Zeile  25 Then

                    Call Farbe3(Zeile, AB, text, 5, True)

                Else

                    If Zeile = 1 Then

                        text = text & ""

                    Else

                        Call Farbe3(Zeile, AB, text, 5, False)

                    End If

                End If

            End If

            If ThisWorkbook.Worksheets(AB).Cells(Zeile, 6) = "0" Then

                text = text & ""

            Else

                If Zeile = 1 Or Zeile = 2 Or Zeile > 16 And Zeile  22 Then

                    If Zeile = 1 Then

                        text = text & ""

                    Else

                        Call Farbe3(Zeile, AB, text, 6, True)

                    End If

                Else

                    Call Farbe3(Zeile, AB, text, 6, False)

                End If

            End If

            If ThisWorkbook.Worksheets(AB).Cells(Zeile, 7) = "0" Then

                text = text & ""

            Else

                Call Farbe3(Zeile, AB, text, 7, False)

            End If

            text = text & "" 'Zeilenende

        Next Zeile

        'Tabellenende deklarieren

        text = text & "
" & Überschrift & "
" & "IH,ASi, AR
 Meistervertretung" & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 1) & "
" & "" & "
" & "" & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 2) & "
" & "" & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 3) & "
" & "" & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 4) & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 4) & "
" & "" & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 5) & "
" & "" & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, 6) & "
" & "" & "
"

        Set iMsg = CreateObject("CDO.Message")

        Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1

        Set Flds = iConf.Fields

        With Flds

            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "******"

            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "******"

            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = ***

            .Update

        End With

        With iMsg

            Set .Configuration = iConf

            .To = "k.j@*****.**"

            .cc = cc

            .BCC = BCC

            .From = "****@*****.**"

            .Subject = "Test AR2"

            .HTMLBody = text

            '.AddAttachment = Dateianhang

            .Send

        End With

End Sub

Hier das "Uuntermakro"
Das mit Zeile >41 musste ich einbauen, weil er schwarze Schrift als rot ausliest, keine Ahnung warum. 
Sub Farbe3(Zeile, AB, text, Spalte, Dick)

    F1 = ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte).Font.ColorIndex

    test333 = ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte)

    If Dick = True Then

        If Zeile > 41 Then

            text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        Else

        If F1 = 33 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        If F1 = 1 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        If F1 = 2 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        If F1 = 3 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        If F1 = -4105 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        End If

    Else

        If Zeile > 41 Then

            text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        Else

            If F1 = 33 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

            If F1 = 1 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

            If F1 = 2 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

            If F1 = 3 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

            If F1 = -4105 Then text = text & "
" & ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte) & "
"

        End If

    End If

End Sub

Soweit so gut.

Aber ich komme mit einigen Punkten nicht weiter.
1. Wie drehe ich die Schrift um 90° in einer bestimmten Zelle?
2. Wie färbe ich den Hintergrund einer Zelle der Tabelle farbig, am besten mit einer Variablen?
3. Wie kann ich mit einer Variablen füllen?
oder so ähnlich?

Vielleicht kann jemand noch eine Vereinfachung meine komplizierten Programmierung sehen und mir mitteilen.
Wäre super.

Danke im Voraus.

Gruß
Karsten
Anzeige

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
11.01.2025 12:38:38
Karsten Jung
Hi

Punkt 2 habe ich zum Teil gelöst bekommen:
Anstatt einfach nehmen.
Aber wie ich das variable mache, habe ich noch nicht herausgefunden.

Gruß

Karsten
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
11.01.2025 12:43:40
Karsten Jung
Ich sehe gerade, dass die ganzen Textzeilen, die die HTML Tabelle erstellen, nicht mit angezeigt werden.
Userbild

So ist eine Hilfe natürlich schwierig.
Anzeige
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
11.01.2025 14:51:47
volti
Hallo Karsten,

es ist durchaus möglich, externe auftauchende MsgBoxen oder Dialogboxen automatisiert per VBA zu beantworten oder zu schließen.
Ist etwas aufwändig und im Einzelfall vielleicht zu kompliziert. Ob es hier möglich ist, müsste man prüfen.
https://www.clever-excel-forum.de/Thread-Dialog-automatisch-schliessen


Ich habe mir Deinen recht umfangreichen nicht näher angeschaut, aber wenn ich formatierte eMail versenden möchte, müsste man m.E. schon RTF oder HTML verwenden.
Du übergibst Deinen Text ja auch an den HTML-Body.
Ich kenne mich mit der CDO.Configuration nicht aus.

Aber wenn ich das richtig sehe, übergibst Du Reintext und keine HTML-Tags.
Mit HTML-Tags kannst Du dann auch farbige Hintergründe oder Tabellen usw. kreieren.
Oder sind die Tags in den leeren "" und verschwunden. Dann solltest Du hier das möglichst richtig darstellen.

Ok, mit Deiner letztem Beitrag sieht man es. Kann man aber nicht lesen.
Stelle doch eine Datei hier ein.

Das kann man zu Fuß machen oder ggf. mit einem Umsetzer.
Wenn DU möchtest, könnte ich mal in meiner Bastelkiste nachschauen, ob ich da noch was passendes habe.

Grüße
KH
Anzeige
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
11.01.2025 15:21:46
volti
Hallo Karsten,

hier noch eine Idee.
Sie ersetzt deine Farbe3-Sub. Sub Test ist ein Aufrufbeispiel.

Dein Basiscode scheint mir auch anpassungsbedürftigt, aber den habe ich mir noch nicht näher angeschaut.

Probiere es halt mal aus. 


Code:


Sub Test()
   text = text & GetHTML(ThisWorkbook.Worksheets(AB).Cells(Zeile, Spalte), True)
End Sub

Function GetHTML(rZelle As Range, Optional bHG As Boolean) As String
' RTF in HTML umwandeln Version für <<<Excel-Zellen>>>
  Dim sHTML As String, sText As String, iPos As Integer
  Dim sFontName As String, sFontSize As String, sUnderline As String
  Dim iColor As Long, iUnderline As Long, sBackground As String
  Dim bItalic As Boolean, bBold As Boolean
  
  If bHG Then                                       ' Hintergrundfarbe
     sBackground = " background-" _
     & GetHexColor(rZelle.Interior.Color) & ";"
  End If
  For iPos = 1 To Len(rZelle.Value)
      With rZelle.Characters(iPos, 1)
          sText = Replace(.text, vbLf, "<br>")      ' Zeilenumbrüche einbauen
          With .Font
              If sFontName <> .Name Or sFontSize <> .Size _
                 Or iColor <> .Color Or bItalic <> .Italic _
                 Or iUnderline <> .Underline Or bBold <> .Bold Then
                 sFontName = .Name                  ' Schriftart
                 sFontSize = .Size: iColor = .Color ' Schriftgröße, -farbe
                 iUnderline = .Underline            ' Unterstreichen
                 bItalic = .Italic: bBold = .Bold   ' Kursiv und Fett

                 If sHTML Like "*<span*" Then
                    sHTML = sHTML & "</span>"       ' Span-Abschluss
                 End If
                 sHTML = sHTML & "<span style='" _
                 & "font-family:" & sFontName & ";" _
                 & " font-size:" & sFontSize & "pt;" _
                 & " " & GetHexColor(iColor) & ";" _
                 & " font-weight: " & IIf(bBold, "bold;", "normal;") _
                 & " font-style: " & IIf(bItalic, "italic;", "normal;") _
                 & " text-decoration: " & IIf(iUnderline > 0, "underline;", "none;") _
                 & sBackground & "'>"               ' Formatierung HTML
              End If
          End With
          sHTML = sHTML & sText                     ' Text_anfügen
          
      End With
  Next iPos
  GetHTML = sHTML & "</span>"

End Function

Private Function GetHexColor(oCol As Variant) As String
  GetHexColor = "color:#" _
  & Right("00" & Hex(oCol And vbRed), 2) _
  & Right("00" & Hex((oCol And vbGreen) \ &H100), 2) _
  & Right("00" & Hex((oCol And vbBlue) \ &H10000), 2)
End Function

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz
Anzeige
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
11.01.2025 17:37:33
Karsten Jung
Vielen Dank,

da werde ich mich mal durcharbeiten um zu verstehen, was du da programmiert hast.

Auf jeden Fall Danke für deine Mühe.

Gruß

Karsten
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
15.01.2025 09:08:30
Karsten Jung
Moin

Ich wollte mich noch mal recht herzlich bedanken!

Ich konnte dein Makro so für mich anpassen, dass es perfekt funktioniert und das ganze Makro zur noch ein paar Zeile hat!

DANKE.
Anzeige
AW: Umstellung auf CDO.message HTMLBody Tabelle, Hilfe nötig
15.01.2025 09:12:58
Volti
Gerne.
Vielen Dank für die Rückmeldung.
Gruß Karl-Heinz

Forumthreads zu verwandten Themen

Abgleich von Daten
Daten

Hallo,
ich habe ein Problem mit einem VBA Code.
Es sollen mehrere Prüfungen erfolgen.
Hallo,
ich habe leider ein VBA-Problem.
Ich möchte gerne zwei Tabellen miteinander vergleichen.
Es gibt drei Spalten mit jeweils 5 Zeilen (als Beispiel). Tabelle1 als "Historie" und Tab...
11.05.2016 14:06:42
Thread-ID: 1492749
1 Beitrag
Automatisiert, Suchfunktion, Filterfunktion, usw.
sweet valentine
Excel Version 365 MSO (Version 2307 Build 16.0.16626.20198) 64 Bit

Hallo,
also ich soll eine Excel-Datei erstellen und habe mit meinem Chef geredet und ihm Bescheid gegeben, das ich probieren werde diese Excel-Datei zu erstellen wenn ich Zeit habe, aber absolut nichts versprechen kann...
12.10.2023 13:51:52
Thread-ID: 1949228
3 Beiträge
Anzeige
Vorletzte Listobject-Zeile vor Einfügen neuer Zeile ändern
FranziskusV
Hallo,

Ich brauche mal wieder Hilfe.

Jetzt kommt der Kontext zu meinem Problem :
Über folgenden Code füge ich über eine Schaltfläche eine Blattzeile ein. Diese Blattzeile wird so eingefügt, dass damit auch automatisch eine Intelligente Tabelle (Listobject mit Name= "TbMonatli...
03.02.2024 16:57:26
Thread-ID: 1963378
2 Beiträge
VBA-Prüfung nach vergessenen Zellen
Sandra

Hallo zusammen,
zuerst einmal "EIN FROHES UND GESUNDES NEUS JAHR!!!"....
Ich bin schon wieder einmal dringend auf Eure Hilfe angewiesen.
Dank Euch habe ich folgendes Makro:
Option Explicit Sub Maengelliste_SKH() Dim oXlSM As Workbook, oXML As Workbook Dim nIndexXLSM, nIndexXML,...
08.01.2015 11:55:34
Thread-ID: 1401386
10 Beiträge
Neue Zeilen per VBA einfügen?
Selma

Hallo Leute,
ich möchte gern per VBA einige neuen Zeilen mit Füllfarben, festen Texten und Formeln einfügen.
I) Ich habe die Tabelle von Zeile 4 bis letzte gefüllte Zeile der Spalte E markiert und wie folgt sortiert:
1. Sortierung nach Spalte H absteigend
2. Sortierung nach Spal...
24.07.2008 02:24:05
Thread-ID: 996216
5 Beiträge
Prüfzeile einbinden
Berndt

Hallo zusammen,
mit folgenden langen Code übertrage ich verschiedene Spalten von mehreren Sheets in ein Sheet zusammenfassend.
Sub Aufgabenübertragung() Dim wksZiel As Worksheet Dim wksQuelle As Worksheet Dim Zeile_1_Z&, Zeile_1_Q&, Zeile_Z&, Zeile_Q&, AnzahlZeilen&...
15.11.2016 13:51:15
Thread-ID: 1524982
7 Beiträge
Anzeige
2 z. T. idenische Makros zu einem zusammenfassen
Sandra

Hallo zusammen.
Ich bin es mal wieder. :)
Und natürlich brauche ich mal wieder Eure Hilfe. Ich habe folgendes Makro, welches bestens funktioniert:
Sub Standard_Maengelliste() Dim oXlSM As Workbook, oXML As Workbook, oXLSX As Workbook Dim nIndexXLSM, nIndexXML, nIndexXLSX, MaxRow As...
08.07.2011 20:42:21
Thread-ID: 1221401
3 Beiträge
Zeilen auf mehreren Datenblättern einfügen
Kai

Hallo zusammen,
ich habe ein ein Tabellenblatt Verwaltung, darauf befindet sich ein CommanButton1, das ein userform1 aufruft.
Darauf befindet sich ComboBox1 und ComboBox2, sowie CommandButton1.
In ComboBox1 wird die Zeile ausgewählt, wo die neue Zeile eingefügt werden soll.
In C...
01.08.2011 09:32:38
Thread-ID: 1224420
11 Beiträge
Excel - Zeilen mit Inhalt in neue Zeilen übernehme
Thomas

Hallo zusammen
Ich habe folgendes Problem im Excel:
In Zeile 1 habe ich in Spalte A einen Namen und in den Spalten D und E einen Text.
In Zeile 2 habe ich in Spalte A einen Namen und in den Spalten C,E und J einen Text.
In Zeile 3 habe ich in Spalte A einen Namen und in den Spal...
23.03.2012 18:03:07
Thread-ID: 1256333
15 Beiträge
nach aktualisierung funktioniert Formel nicht mehr
Angelika

Hallo
Ich benötige bitte dringend nochmal Hilfe.
Tabelle hab ich beigefügt
https://www.herber.de/bbs/user/79253.xlsm
Code siehe unten
Kurze Erklärung
In Tabelle Daten1 werden in Spalte K40:T40 manuell Werte eingegeben
Dank Hilfe vom Forum geschieht nun folgendes:<...
07.03.2012 15:53:58
Thread-ID: 1254029
4 Beiträge
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Live-Forum - Die aktuellen Beiträge
Datum
Titel
14.05.2026 13:31:09
Zeichen ausblenden
14.05.2026 09:50:42
Makro für MacOs
13.05.2026 19:14:18
Gleichheitszeichen
13.05.2026 14:24:56
VBA Projekt Passwort automatisch eingeben
13.05.2026 08:49:41
Reale Berechnung ohne Nachkommawerte
Keine passende Antwort im Forumarchiv gefunden?
Stelle deine Frage im Live-Forum