Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.
Clever-Excel-Forum › Office-Anwendungen › Outlook v
E-Mail Ablage

Thema geschlossen 
Baumstrukturmodus
E-Mail Ablage
lukas-2000 Offline
Benutzer
Registriert seit: 19.09.2017
Version(en): 2016
#1
26.10.2018, 16:56
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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#2
26.10.2018, 17:15
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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
lukas-2000 Offline
Benutzer
ThreadStarter

Registriert seit: 19.09.2017
Version(en): 2016
#3
26.10.2018, 17:55
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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#4
26.10.2018, 18:07
Hallo Lukas,

du hast unten beim Speichern strSave, müsste auch strSavePath sein ...
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
lukas-2000 Offline
Benutzer
ThreadStarter

Registriert seit: 19.09.2017
Version(en): 2016
#5
29.10.2018, 18:35
(26.10.2018, 18:07)schauan schrieb: Hallo Lukas,

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

Hallo André,

das ist mir garnicht aufgefallen mit dem strSavePath 16 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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#6
29.10.2018, 19:15
Hallo Lukas,

dann erst mal die Frage - hat es denn vor der Änderung mit der Erweiterung zur Ordnerauswahl funktioniert?
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
lukas-2000 Offline
Benutzer
ThreadStarter

Registriert seit: 19.09.2017
Version(en): 2016
#7
29.10.2018, 19:57
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
Suchen
Antworten Top
lukas-2000 Offline
Benutzer
ThreadStarter

Registriert seit: 19.09.2017
Version(en): 2016
#8
31.10.2018, 16:22
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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#9
31.10.2018, 18:37
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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
lukas-2000 Offline
Benutzer
ThreadStarter

Registriert seit: 19.09.2017
Version(en): 2016
#10
05.11.2018, 19:50
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
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste