Emails im jeweiligen Format speichern

Internet E-Mail
#1

Hallo,

ich habe ein Makro für Outlook geschrieben, das Makro speichert markierte Emails im jeweiligen Format. Dabei werden bei den HTML
Nachrichten die Bilder getrennt von der Seite in den Ordner geschrieben.
Das an und für sich ist kein Problem, aber die Referenz zu den Bildern
ist falsch, so das das Bild nicht in der Html-Seite angezeigt wird.

Mich würde nun interessieren, ob es eine Möglichkeit gibt. Das der Pfad
zu den Bildern korrekt gesetzt wird in der Html-Seite??

Gruss Omega_D

#2

Hallo Omega_D,

Mich würde nun interessieren, ob es eine Möglichkeit gibt. Das
der Pfad zu den Bildern korrekt gesetzt wird in der Html-Seite??

könntest du mal bitte eine Fernwartung einrichten?

Leider kann ich von hier deinen Quellcode des Makros nicht sehen, somit auch nicht sagen, was du falsch gemacht hast. Aber mit einer Fernwartung auf deinen PC dürfte es dann kein Problem sein.

Grüße aus Schönberg (Lübeck)
Wolfgang
(Netwolf)

#3

Hallo Wolfgang,

ich habe auch keinen Code reingestellt, aber das werde ich jetzt nachholen.

Option Explicit

Sub Command1_Click()

'rem Deklaration und Definition
Dim myOlApp As Outlook.Application
Dim myMail As Outlook.MailItem
Dim mail As String
Dim pfad As String
Dim fs As Object
Dim anhang As Attachment
Dim zaehler As Integer

'Erzeuge Objektinstanz für mailitem
Set myOlApp = CreateObject(„Outlook.Application“)
Set myMail = myOlApp.CreateItem(olMailItem)
Set fs = CreateObject(„Scripting.FileSystemObject“)

'Inputbox test
pfad = InputBox(„Eingabe des Pfades:“, „Pfadeingabe“, „c:\temp“)

'prüft ob das Verzeichnis existiert
If fs.FolderExists(pfad) = True Then
'MsgBox („Pfad existiert“)
Else
MsgBox („Pfad existiert nicht Programmabbruch“)
End
End If

'Für jedes ausgewähltes Objekt im explorer
For Each myMail In Outlook.ActiveExplorer.Selection

'Wenn email eine Text
If myMail.GetInspector.EditorType = olEditorText Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, " ")
mail = Replace(mail, „&“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „?“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „/“, " ")
mail = Replace(mail, „*“, " ")
mail = Replace(mail, „|“, " ")

'Mails speichern
myMail.SaveAs pfad & mail & „.txt“, olTXT

'Anhang mit speichern
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & anhang.FileName

Next

Else

MsgBox („Leerer Body“)
End If
End If

'wenn email eine Html
If myMail.GetInspector.EditorType = olEditorHTML Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, " ")
mail = Replace(mail, „&“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „?“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „/“, " ")
mail = Replace(mail, „*“, " ")
mail = Replace(mail, „|“, " ")

For zaehler = 1 To 2

'Mails speichern
myMail.SaveAs pfad & mail & „.html“, olHTML

Next

'Anhang mit speichern
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & anhang.FileName

Next

Else

MsgBox („Leerer Body“)
MsgBox (myMail.Body)
End If
End If
'wenn email eine rtf
If myMail.GetInspector.EditorType = olEditorRTF Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, " ")
mail = Replace(mail, „&“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „?“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „/“, " ")
mail = Replace(mail, „*“, " ")
mail = Replace(mail, „|“, " ")

'Mails speichern
myMail.SaveAs pfad & mail & „.rtf“, olRTF

'Anhang mit speichern
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & anhang.FileName
Next
Else
MsgBox („Leerer Body“)
End If
End If

'wenn email eine doc
If myMail.GetInspector.EditorType = olEditorWord Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, " ")
mail = Replace(mail, „&“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „?“, " ")
mail = Replace(mail, „“, " ")
mail = Replace(mail, „/“, " ")
mail = Replace(mail, „*“, " ")
mail = Replace(mail, „|“, " ")

'Mails speichern
myMail.SaveAs pfad & mail & „.doc“, olDoc

'Anhang mit speichern
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & anhang.FileName

Next

Else

MsgBox („Leerer Body“)
End If
End If

Next

MsgBox („Speichern beendet“)
End Sub

Gruss Omega_D

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

#4

Lösung gefunden
Hallo,

ich habe eine mögliche Lösung gefunden.

Hier nun der Code:

Option Explicit

Sub Datei_verarbeiten(pfad As String, mail As String, myMail As Outlook.MailItem)

Dim a As Byte
Dim stext, sText1, ltext, rtext, nText As String
Dim z, startWert, endwert, zaehler As Long
Dim anhang As Outlook.Attachment

a = FreeFile

Open pfad & mail & „.html“ For Input As a
While Not EOF(a)
Input #a, sText1
stext = stext & " " & sText1
Wend
Close #a

'Anhang mit speichern
startWert = 1
zaehler = 1
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & mail & „_“ & anhang.FileName
'MsgBox (anhang.DisplayName)

If InStr(1, anhang.FileName, „.gif“) 0 Then

startWert = InStr(startWert, stext, „src=“)
endwert = InStr(startWert, stext, „>“)
ltext = Mid(stext, 1, startWert + 3)
rtext = Mid(stext, endwert, Len(stext))
nText = ltext & ChrW(34) & mail & „_“ & anhang.FileName & ChrW(34) & rtext
stext = nText
startWert = endwert

End If

If InStr(1, anhang.FileName, „.jpg“) 0 Then

startWert = InStr(startWert, stext, „src=“)
endwert = InStr(startWert, stext, „>“)
ltext = Mid(stext, 1, startWert + 3)
rtext = Mid(stext, endwert, Len(stext))
nText = ltext & ChrW(34) & mail & „_“ & anhang.FileName & ChrW(34) & rtext
stext = nText
startWert = endwert

End If

If InStr(1, anhang.FileName, „.png“) 0 Then

startWert = InStr(startWert, stext, „src=“)
endwert = InStr(startWert, stext, „>“)
ltext = Mid(stext, 1, startWert + 3)
rtext = Mid(stext, endwert, Len(stext))
nText = ltext & ChrW(34) & mail & „_“ & anhang.FileName & ChrW(34) & rtext
stext = nText
startWert = endwert

End If

Next
Open pfad & mail & „.html“ For Output As a
Print #a, stext
Close #a

End Sub

Sub Command1_Click()

'rem Deklaration und Definition
Dim myOlApp As Outlook.Application
Dim myMail As Outlook.MailItem
Dim mail As String
Dim pfad As String
Dim fs As Object
Dim anhang As Attachment
Dim zaehler As Integer

'Erzeuge Objektinstanz für mailitem
Set myOlApp = CreateObject(„Outlook.Application“)
Set myMail = myOlApp.CreateItem(olMailItem)
Set fs = CreateObject(„Scripting.FileSystemObject“)

'Inputbox test -> vbCrLf für Zeilenumbruch
pfad = InputBox(„Eingabe des Pfades:“, „Pfadeingabe“, „c:\temp“)

'prüft ob das Verzeichnis existiert
If fs.FolderExists(pfad) = True Then
'MsgBox („Pfad existiert“)
Else
MsgBox („Pfad existiert nicht Programmabbruch“)
End
End If

'Für jedes ausgewähltes Objekt im explorer
For Each myMail In Outlook.ActiveExplorer.Selection

'Wenn email txt
If myMail.GetInspector.EditorType = olEditorText Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, „_“)
mail = Replace(mail, „&“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „?“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „/“, „_“)
mail = Replace(mail, „*“, „_“)
mail = Replace(mail, „|“, „_“)
mail = Replace(mail, " ", „_“)

For zaehler = 1 To 2

'Mails speichern
myMail.SaveAs pfad & mail & „.txt“, olTXT

Next

'Anhang mit speichern
zaehler = 1
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & „#“ & mail & „#“ & anhang.FileName
zaehler = zaehler + 1
Next

Else

MsgBox („Leerer Body“)
End If
End If

'wenn email als html
If myMail.GetInspector.EditorType = olEditorHTML Then

'If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, „_“)
mail = Replace(mail, „&“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „?“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „/“, „_“)
mail = Replace(mail, „*“, „_“)
mail = Replace(mail, „|“, „_“)
mail = Replace(mail, " ", „_“)

For zaehler = 1 To 2

'Mails speichern
myMail.SaveAs pfad & mail & „.html“, olHTML

Next

'Aufrufen eine Methode für das einfügen der Bilder in die Email
Call Datei_verarbeiten(pfad, mail, myMail)

'Else

’ MsgBox („Leerer Body“)
'End If
End If
'wenn email rtf
If myMail.GetInspector.EditorType = olEditorRTF Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, „_“)
mail = Replace(mail, „&“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „?“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „/“, „_“)
mail = Replace(mail, „*“, „_“)
mail = Replace(mail, „|“, „_“)
mail = Replace(mail, " ", „_“)

For zaehler = 1 To 2

'Mails speichern
myMail.SaveAs pfad & mail & „.rtf“, olRTF

Next

'Anhang mit speichern
zaehler = 1
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & „#“ & mail & „#“ & anhang.FileName
zaehler = zaehler + 1
Next
Else
MsgBox („Leerer Body“)
End If
End If

'wenn email doc
If myMail.GetInspector.EditorType = olEditorWord Then

If myMail.Body „“ Then

mail = Replace(myMail.Subject, „:“, „_“)
mail = Replace(mail, „&“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „?“, „_“)
mail = Replace(mail, „“, „_“)
mail = Replace(mail, „/“, „_“)
mail = Replace(mail, „*“, „_“)
mail = Replace(mail, „|“, „_“)
mail = Replace(mail, " ", „_“)

'Mails speichern
myMail.SaveAs pfad & mail & „.doc“, olDoc

'Anhang mit speichern
zaehler = 1
For Each anhang In myMail.Attachments
anhang.SaveAsFile „c:\temp“ & „#“ & mail & „#“ & anhang.FileName
zaehler = zaehler + 1
Next

Else

MsgBox („Leerer Body“)
End If
End If

Next

MsgBox („Speichern beendet“)
End Sub

Vielleicht hilft das mal jemanden! :smile:

Gruss Omega_D