E-Mail Ablage

[lukas-2000]

Hallo Community,
 
ich bin momentan dabei eine E-Mail Ablage in Outlook zu implementieren. Das Ganze soll so funktionieren, dass ich in meinem Menüband einen Button habe, mit dem ich die aktuell geöffnete E-Mail, als PDF, unter einem auswählbaren Ordner ablegen kann. Hinzu kommt, dass die Dateinamen mit dem aktuellen Datum versehen werden sollen.
 
Ich habe das Internet jetzt schon eine ganze Weile nach Lösungen durchsucht und folgendes gefunden:

Code:

Sub Ablegen()   
   Dim strPath As String
Dim strText As String
strPath = Environ("USERPROFILE") & "\Desktop\"
 If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
 Set obj = Application.ActiveWindow
 Set obj = obj.Selection(1)
 Else
  Set objInspector = ActiveInspector
  objInspector.Activate
     If objInspector.IsWordMail Then
        Set obj = Application.ActiveInspector.CurrentItem
     End If
 End If   
With obj
   strText = Replace(.Subject, "/", "_")
   strText = Replace(strText, "!", "")
   strText = Replace(strText, ".", "_")
   strText = Replace(strText, "\", "_")
   strText = Replace(strText, ":", "_")
   strText = Replace(strText, "(", "")
   strText = Replace(strText, ")", "")
   strText = Replace(strText, """", "")
   .SaveAs strPath & strText & Format(.ReceivedTime, "(DD.MM.YYYY_hh-mm)") & ".msg", olMSG
End With
End Sub

Mit diesem Code ist es schonmal möglich, eine einzelne E-Mail als Outlook-Datei, über einen Button, abzulegen. Dabei wird gleichzeitig, das aktuelle Datum mit Uhrzeit in dem Dateinamen eingefügt. Allerdings muss ich den Speicherort vorher definieren, also ich kann ihn nicht per Auswahlfenster bestimmen und die Datei wird nicht als PDF, sondern Msg-Datei abgelegt.
 
Deswegen frage ich nun hier im Forum mal nach ob eventuell jemand eine Idee hat, wie man das ganze entsprechend meinen Vorstellungen anpassen könnte.
 
Ich würde mich riesig über eine Antwort freuen!
 
MfG Lukas

[schauan]

Hallo Lukas,

ich habe das bei mir so:

Code:

Option Explicit

Sub test()
Dim StrSavePath As String
   StrSavePath = BrowseForFolder
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select
ExitFunction:
    Set ShellApp = Nothing
End Function

[lukas-2000]

Hallo André,

danke für deine Antwort!

Ich habe jetzt mal probiert die Funktion in meinen Code einzubauen. Allerdings hat dies nicht geklappt. Kannst nochmal schauen ob ich irgendetwas falsch gemacht habe, ich bin absolut kein Profi.

Code:

Sub Einzeln()
   Dim StrSavePath As String
  StrSavePath = BrowseForFolder
 If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
 Set obj = Application.ActiveWindow
 Set obj = obj.Selection(1)
 Else
  Set objInspector = ActiveInspector
  objInspector.Activate
     If objInspector.IsWordMail Then
        Set obj = Application.ActiveInspector.CurrentItem
     End If
 End If
With obj
   strText = Replace(.Subject, "/", "_")
   strText = Replace(strText, "!", "")
   strText = Replace(strText, ".", "_")
   strText = Replace(strText, "\", "_")
   strText = Replace(strText, ":", "_")
   strText = Replace(strText, "(", "")
   strText = Replace(strText, ")", "")
   strText = Replace(strText, """", "")
   .SaveAs strPath & strText & Format(.ReceivedTime, "(DD.MM.YYYY_hh-mm)") & ".msg", olMSG
End With

End Sub

Function BrowseForFolder(Optional OpenAt As String) As String
   Dim ShellApp As Object
   Set ShellApp = CreateObject("Shell.Application"). _
   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
   On Error Resume Next
   BrowseForFolder = ShellApp.self.Path
   On Error GoTo 0
   Select Case Mid(BrowseForFolder, 2, 1)
   Case Is = ":"
       If Left(BrowseForFolder, 1) = ":" Then
           BrowseForFolder = ""
       End If
   Case Is = "\"
       If Not Left(BrowseForFolder, 1) = "\" Then
           BrowseForFolder = ""
       End If
   Case Else
       BrowseForFolder = ""
   End Select
ExitFunction:
   Set ShellApp = Nothing
End Function

Gruß Lukas

[schauan]

Hallo Lukas,

du hast unten beim Speichern strSave, müsste auch strSavePath sein ...

[lukas-2000]

Hallo Lukas,

du hast unten beim Speichern strSave, müsste auch strSavePath sein ...

Hallo André,

das ist mir garnicht aufgefallen mit dem strSavePath Ich habe den Code nun folgendermaßen abgeändert:

Code:

Sub Einzeln()
   Dim strSavePath As String
   Dim strText As String
  strSavePath = BrowseForFolder
 If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
 Set obj = Application.ActiveWindow
 Set obj = obj.Selection(1)
 Else
  Set objInspector = ActiveInspector
  objInspector.Activate
     If objInspector.IsWordMail Then
        Set obj = Application.ActiveInspector.CurrentItem
     End If
 End If
With obj
   strText = Replace(.Subject, "/", "_")
   strText = Replace(strText, "!", "")
   strText = Replace(strText, ".", "_")
   strText = Replace(strText, "\", "_")
   strText = Replace(strText, ":", "_")
   strText = Replace(strText, "(", "")
   strText = Replace(strText, ")", "")
   strText = Replace(strText, """", "")
   .SaveAs strSavePath & strText & Format(.ReceivedTime, "(DD.MM.YYYY_hh-mm)") & ".msg", olMSG  
End With
End Sub

Allerdings funktioniert es so noch nicht. Es wird keine Datei in meinem ausgewählten Ordner abgelegt. Es kommt auch keine Fehlermeldung, irgendwas ist da noch unklar, ich weiß nur nicht was.

Hast du eine Idee wo das herkommen könnte?

Gruß Lukas

[schauan]

Hallo Lukas,

dann erst mal die Frage - hat es denn vor der Änderung mit der Erweiterung zur Ordnerauswahl funktioniert?

[lukas-2000]

Entschuldige das ich das nicht erwähnt habe.

Mit diesem Code hat es vorher einwandfrei funktioniert!

Code:

Sub test()
  Dim strPath As String
Dim strText As String
strPath = Environ("USERPROFILE") & "\Desktop\"
If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
Set obj = Application.ActiveWindow
Set obj = obj.Selection(1)
Else
 Set objInspector = ActiveInspector
 objInspector.Activate
    If objInspector.IsWordMail Then
       Set obj = Application.ActiveInspector.CurrentItem
    End If
End If
With obj
  strText = Replace(.Subject, "/", "_")
  strText = Replace(strText, "!", "")
  strText = Replace(strText, ".", "_")
  strText = Replace(strText, "\", "_")
  strText = Replace(strText, ":", "_")
  strText = Replace(strText, "(", "")
  strText = Replace(strText, ")", "")
  strText = Replace(strText, """", "")
  .SaveAs strPath & strText & Format(.ReceivedTime, "(DD.MM.YYYY_hh-mm)") & ".msg", olMSG
End With
End Sub

Nun klappt es aber mit folgender erweiterung nicht:

Code:

Sub test()  
   Dim strSavePath As String
   Dim strText As String
  strSavePath = BrowseForFolder
 If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
 Set obj = Application.ActiveWindow
 Set obj = obj.Selection(1)
 Else
  Set objInspector = ActiveInspector
  objInspector.Activate
     If objInspector.IsWordMail Then
        Set obj = Application.ActiveInspector.CurrentItem
     End If
 End If   
With obj
   strText = Replace(.Subject, "/", "_")
   strText = Replace(strText, "!", "")
   strText = Replace(strText, ".", "_")
   strText = Replace(strText, "\", "_")
   strText = Replace(strText, ":", "_")
   strText = Replace(strText, "(", "")
   strText = Replace(strText, ")", "")
   strText = Replace(strText, """", "")    
   .SaveAs strSavePath & strText & Format(.ReceivedTime, "(DD.MM.YYYY_hh-mm)") & ".msg", olMSG
End With
End Sub

Natürlich hängt hinten noch die Function dran ;)

Gruß Lukas

[lukas-2000]

Hallo,

ich habe nun nochmal etwas rumprobiert und nun den Fehler nun gefunden. Bei BrowseForFolder = ShellApp.self.Path hat [ & "\" ] gefehlt, nun funktioniert es bestens!

Code:

Function BrowseForFolder(Optional OpenAt As String) As String
   Dim ShellApp As Object
   Set ShellApp = CreateObject("Shell.Application"). _
   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
   On Error Resume Next
   BrowseForFolder = ShellApp.self.Path & "\"
   On Error GoTo 0
   Select Case Mid(BrowseForFolder, 2, 1)
   Case Is = ":"
       If Left(BrowseForFolder, 1) = ":" Then
           BrowseForFolder = ""
       End If
   Case Is = "\"
       If Not Left(BrowseForFolder, 1) = "\" Then
           BrowseForFolder = ""
       End If
   Case Else
       BrowseForFolder = ""
   End Select
ExitFunction:
   Set ShellApp = Nothing
End Function

Es gibt allerdings noch ein weiteres Problem. Mit einem anderen Button möchte ich alle Emails in einem Ordner, also beispielsweiße Papierkorb, ablegen. Momentan funktioniert es nur wenn ich zuvor alle Emails makerie. Das ist aber erstmal nicht das größte Problem. Das größte Problem ist, dass sich Outlook meinstens aufhängt wenn sehr viele Emails abgelegt werden sollen. Ist es möglich die Emails irgendwie nach und nach ab zu speichern, damit genau das nicht mehr passiert?

Gruß Lukas

[schauan]

Hallo Lukas,

im Prinzip geht das so. Auf jeden Fall erst mal mit einem Testordner probieren und schrittweise ausführen!

Code:

Sub Items_loeschen()
'Variablendeklarationen
Dim olMapiFolder As olMapiFolderlook.MAPIFolder
Dim objItem As Object
Dim iCnt As Integer
'Ordnerobject setzen
Set olMapiFolder = GetObject("", "olMapiFolderlook.Application").GetNamespace("Mapi"). _
    GetDefaultFolder(olFolderInbox).Folders("Test")
'Schleife ueber alle Elemente des Ordners
For iCnt = olMapiFolder.objItems.Count To 1 Step -1
    'Element loeschen
    olMapiFolder.objItems(iCnt).Delete
'Ende Schleife ueber alle Elemente des Ordners
Next
End Sub

[lukas-2000]

Hallo André,

ich habe deinen Code mal ausprobiert und es tritt dabei ein Fehler auf. Als Fehler wird mir bei ,,olMapiFolder As olMapiFolderlook.MAPIFolder", Fehler beim Kompilieren: Benutzerdefinierter Typ nicht definiert, ausgegeben.

Hast du eine Idee waran dies liegen könnte?

Gruß Lukas