manchmal funktioniert es

Hallo zusammen,
ich habe für die Arbeit mehrere Makros erstellt, die alle sehr ähnlich aussehen und mir und meinen Kollegen die Arbeit etwas vereinfachen sollen. Ich finde leider keine zufrieden stellende Lösung und bitte daher um Rat.
Ich habe ein VBA-Makro geschrieben, welches eine E-Mail erstellt mit gewissen Parametern. Leider funktioniert es nicht zuverlässig. Manchmal fehlen Inhalte, manchmal führt er nicht die exakte Reihenfolge aus und machmal gibt er ne Fehlermeldung aus. Aber nach mehrfachen ausführen des Makros funktioniert es irgendwann, aber ich verstehe nicht warum?
Ich habe mal ein paar Kommentare hinzugefügt, damit man nachvollziehen kann, was ich da vor habe.

Sub Test() 'Screenshot erstellen ThisWorkbook.Worksheets("Test").Range("A1:G33").CopyPicture xlScreen, xlBitmap ' Variablen erstellen Dim oApp As Object Dim Signatur As Object Set oApp = CreateObject("Outlook.Application") Set Signatur = CreateObject("Outlook.Application") On Error Resume Next 'E-Mail erstellen With oApp.CreateItem(0) Application.Wait (Now + TimeValue("0:00:01")) .To = ThisWorkbook.Worksheets("Seite_1").Range("D45").Value .Subject = ThisWorkbook.Worksheets("Seite_1").Range("D44").Value .CC = ThisWorkbook.Worksheets("Seite_1").Range("D46").Value .Body = ThisWorkbook.Worksheets("Seite_1").Range("C49").Value .Display SendKeys "^{END}", True ' SendKeys "~", True ' SendKeys "^v", True ' Bild einfügen SendKeys "~", True ' .Recipients.ResolveAll Application.Wait (Now + TimeValue("0:00:01")) With Signatur.CreateItem(0) 'Signatur kopieren aus einer leeren E-Mail Application.Wait (Now + TimeValue("0:00:01")) .Display SendKeys "{TAB}", True SendKeys "{TAB}", True SendKeys "{TAB}", True SendKeys "^a", True SendKeys "^c", True SendKeys "%{F4}" End With SendKeys "^v", True SendKeys "{PGUP}", True SendKeys "{PGUP}", True Application.Wait (Now + TimeValue("0:00:01")) End With On Error GoTo 0 Set oApp = Nothing Set Signatur = Nothing End Sub

Wäre nice, wenn mir jemand weiterhelfen könnte.
@Signatur. Wäre schön wenn mir jemand eine elegantere und alternative Lösung mitteilen könnte.
MfG Itryit

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Itryit,
probiere mal, ob Dir dieses hier vielleicht schon reicht und funkioniert.
Falls nicht, oder Anlagen dran sollen, der body-Text formatiert werden soll usw. kannst Du Dich ja wieder melden.

Option Explicit

Option COMPARE TEXT

Sub Mail_Senden_Formatierung()

'Sendet eine formatierte Mail mit Signatur

 Dim WSh As Worksheet, sMailText As String

 Set WSh = ThisWorkbook.Sheets("Seite_1")

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

  .BodyFormat = 3          'HTML-Format, Angabe optional

  .To = WSh.Range("D45").Value

  .CC = WSh.Range("D46").Value

'  .Bcc = wsh.Range("D46").Value

  .Subject = WSh.Range("D44").Value

  sMailText = WSh.Range("C49").Value

  .GetInspector

  .HTMLBody = Replace(sMailText, vbLf, "&LT;br&GT;") _

   & Range2Html(ThisWorkbook.Sheets("Test").Range("A1:G33")) & .HTMLBody

  .Display

'  .Recipients.ResolveAll

 End With

End Sub

Private Function Range2Html(oBereich As Range) As String

'Gibt den angegebenen Bereich als HTML zurück

 Dim sTmpFile As String, iFF As Integer

 sTmpFile = Environ$("temp") & "\" & Format(Now, "ddmmyyhhmmss") & ".htm"

 With oBereich.Parent.Parent.PublishObjects.Add( _

      SourceType:=xlSourceRange, _

      Filename:=sTmpFile, _

      Sheet:=oBereich.Parent.Name, _

      Source:=oBereich.Address, _

      HtmlType:=xlHtmlStatic)

  .Publish Create:=True

 End With

 iFF = FreeFile

 Open sTmpFile For Input As iFF

 Range2Html = Replace(Input(LOF(iFF), iFF), "align=center x:publishsource=", _

              "align=left x:publishsource=")

 Close iFF

 Kill sTmpFile

End Function

viele Grüße
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread