Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1220to1224
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

off topic - Outlook

off topic - Outlook
PeterO
Hallo Forum,
ich erlaube mir hier mal die Frage nach einem vergleichbar guten Forum für Outlook (hier 2003).
Beim googlen nach einer Lösung per VBA ein Macro zu erstellen, dass mir alle Mailanhänge von markierten (angeklickten) Mails in einen vordefinierten Ordner auf dem Desktop speichert, habe ich bisher nichts brauchbares gefunden.
Wäre schön, wenn ihr einen Link oder gar eine Lösung für mich habt.
Gruß Peter

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: off topic - Outlook
20.07.2011 14:38:53
PeterO
Hallo Rudi,
danke für die Info. Kannte ich bislang noch nicht, da ich bisher immer nur mit Excel zu tun hatte und es dafür ja tolle Foren gibt :-)
Habe auch gleich eine Lösung gefunden.
Gruß Peter
AW: off topic - Outlook
21.07.2011 10:41:08
Martin
Hallo,
vor einiger Zeit habe ich das Gleiche gesucht und wurde fündig. Mit folgendem Code kannst du Mails anklicken und als Msg speichern:
'==========================================================================
'Export Outlook e-mail to drive
'--------------------------------------------------------------------------
'Author: Michael Wöhrer
'Version: 0.2, 2009-01-20
'==========================================================================
'Terms and conditions
' You can use, redistribute and/or modify this code under the terms of
' the SOFTWARE GUIDE LICENSE. This code is distributed in the hope that it
' will be useful, but WITHOUT ANY WARRANTY; without even the implied
' warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
' See the SOFTWARE GUIDE LICENSE for more details.
'==========================================================================
Option Explicit
'-------------------------------------------------------------
' OPTIONS
'-------------------------------------------------------------
'Email format:
' MSG = Outlook msg format (incl. attachments, embedded objects etc.)., TXT = plain text
Private Const EXM_OPT_MAILFORMAT As String = "MSG"
'Date format of filename
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyy-mm-dd_hh-nn-ss"
'Build filename; placeholders: for date, for sender's name, for receiver, for subject
Private Const EXM_OPT_FILENAME_BUILD As String = ""
'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
Private Const EXM_OPT_USEBROWSER As Boolean = True
'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE)
Private Const EXM_OPT_TARGETFOLDER As String = "D:\"
'Maximum number of emails to be selected & exported. Please don't use a huge number as this will cause
'performance and maybe other issues. Recommended is a value between 5 and 20.
Private Const EXM_OPT_MAX_NO As Integer = 100
'Email subject prefixes (such us "RE:", "FW:" etc.) to be removed. Please note that this is a
'RegEx expression, google for "regex" for further information. For instance "\s" means blank " ".
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
'-------------------------------------------------------------
'-------------------------------------------------------------
' TRANSLATIONS
'-------------------------------------------------------------
'-- English
'Const EXM_007 = "Script terminated"
'Const EXM_013 = "Selected Outlook item is not an e-mail"
'Const EXM_014 = "File already exists"
'-- German
Private Const EXM_001 As String = "Die E-Mail wurde erfolgreich abgelegt."
Private Const EXM_002 As String = "Die E-Mail konnte nicht abgelegt werden, Grund:"
Private Const EXM_003 As String = "Ausgewählter Pfad:"
Private Const EXM_004 As String = "E-Mail(s) ausgewählt und erfolgreich abgelegt."
Private Const EXM_005 As String = ""
Private Const EXM_006 As String = ""
Private Const EXM_007 As String = "Script abgebrochen"
Private Const EXM_008 As String = "Fehler aufgetreten: Sie haben mehr als [LIMIT_SELECTED_ITEMS] E-Mails ausgewählt. Die Aktion wurde beendet."
Private Const EXM_009 As String = "Es wurde keine E-Mail ausgewählt."
Private Const EXM_010 As String = "Es ist ein Fehler aufgetreten: es war keine Email im Fokus, so dass die Ablage nicht erfolgen konnte."
Private Const EXM_011 As String = "Es ist ein Fehler aufgetreten:"
Private Const EXM_012 As String = "Die Aktion wurde beendet."
Private Const EXM_013 As String = "Ausgewähltes Outlook-Dokument ist keine E-Mail"
Private Const EXM_014 As String = "Datei existiert bereits"
Private Const EXM_015 As String = ""
Private Const EXM_016 As String = "Bitte wählen Sie den Ordner zum Exportieren:"
Private Const EXM_017 As String = "Fehler beim Exportieren aufgetreten"
Private Const EXM_018 As String = "Export erfolgreich"
Private Const EXM_019 As String = "Bei [NO_OF_FAILURES] E-Mail(s) ist ein Fehler aufgetreten:"
Private Const EXM_020 As String = "[NO_OF_SELECTED_ITEMS] E-Mail(s) wurden ausgewählt und [NO_OF_SUCCESS_ITEMS] E-Mail(s) erfolgreich abgelegt."
'-------------------------------------------------------------
'-------------------------------------
'For browse folder
'-------------------------------------
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Sub ExportEmailToDrive()
Const PROCNAME As String = "ExportEmailToDrive"
On Error GoTo ErrorHandler
Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim myItem As Object
Dim olSelection As Selection
Dim strBackupPath As String
Dim intCountAll As Integer
Dim intCountFailures As Integer
Dim strStatusMsg As String
Dim vSuccess As Variant
Dim strTemp1 As String
Dim strTemp2 As String
Dim strErrorMsg As String
'Get target drive
If (EXM_OPT_USEBROWSER = True) Then
strBackupPath = GetFileDir
If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
strErrorMsg = Mid(strBackupPath, 16, 9999)
Error 5004
End If
Else
strBackupPath = EXM_OPT_TARGETFOLDER
End If
If strBackupPath = "" Then GoTo ExitScript
If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
'Process according to what is in the focus: an opened e-mail or a folder with selected e- _
mails.
'Case 2 would also work for opened e-mail, however it does not always work (for instance if
' an e-mail is saved on the file system and being opened from there).
Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder
If myfolder Is Nothing Then Error 5001
If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript
'Stop if more than x emails selected
If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002
'No email selected at all?
If myExplorer.Selection.Count = 0 Then Error 5003
Set olSelection = myExplorer.Selection
intCountAll = 0
intCountFailures = 0
For Each myItem In olSelection
intCountAll = intCountAll + 1
vSuccess = ProcessEmail(myItem, strBackupPath)
If (Not vSuccess = True) Then
Select Case intCountFailures
Case 0: strStatusMsg = vSuccess
Case 1: strStatusMsg = "1x " & strStatusMsg & Chr(10) & "1x " & vSuccess
Case Else: strStatusMsg = strStatusMsg & Chr(10) & "1x " & vSuccess
End Select
intCountFailures = intCountFailures + 1
End If
Next
If intCountFailures = 0 Then
strStatusMsg = intCountAll & " " & EXM_004
End If
'Final Message
If (intCountFailures = 0) Then  'No failure occurred
MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, _
48, EXM_017
Else    'More than one email was selected and at least one failure occurred
strTemp1 = Replace(EXM_020, "[NO_OF_SELECTED_ITEMS]", intCountAll)
strTemp1 = Replace(strTemp1, "[NO_OF_SUCCESS_ITEMS]", intCountAll - intCountFailures)
strTemp2 = Replace(EXM_019, "[NO_OF_FAILURES]", intCountFailures)
MsgBox strTemp1 & Chr(10) & Chr(10) & strTemp2 & Chr(10) & Chr(10) & strStatusMsg _
& Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
End If
ExitScript:
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 5001:  'Not an email
MsgBox EXM_010, 64, EXM_007
Case 5002:
MsgBox Replace(EXM_008, "[LIMIT_SELECTED_ITEMS]", EXM_OPT_MAX_NO), 64, EXM_007
Case 5003:
MsgBox EXM_009, 64, EXM_007
Case 5004:
MsgBox EXM_011 & Chr(10) & Chr(10) & strErrorMsg, 48, EXM_007
Case Else:
MsgBox EXM_011 & Chr(10) & Chr(10) _
& Err & " - " & Error$ & Chr(10) & Chr(10) & EXM_012, 48, EXM_007
End Select
Resume ExitScript
End Sub

Private Function ProcessEmail(myItem As Object, strBackupPath As String) As Variant
'Saves the e-mail on the drive by using the provided path.
'Returns TRUE if successful, and FALSE otherwise.
Const PROCNAME As String = "ProcessEmail"
On Error GoTo ErrorHandler
Dim myMailItem As MailItem
Dim strDate As String
Dim strSender As String
Dim strReceiver As String
Dim strSubject As String
Dim strFinalFileName As String
Dim strFullPath As String
Dim vExtConst As Variant
Dim vTemp As String
Dim strErrorMsg As String
If TypeOf myItem Is MailItem Then
Set myMailItem = myItem
Else
Error 1001
End If
'Set filename
strDate = Format(myMailItem.ReceivedTime, "dd.mm.yyyy   -   hh_mm_ss") ',  _
EXM_OPT_FILENAME_DATEFORMAT)
strSender = myMailItem.SenderName
strReceiver = myMailItem.To 'All receiver, semikolon separated string
If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";")  _
- 1)
strSubject = myMailItem.Subject
strFinalFileName = EXM_OPT_FILENAME_BUILD
strFinalFileName = Replace(strFinalFileName, "", strDate & " - ")
strFinalFileName = Replace(strFinalFileName, "", strSender)
strFinalFileName = Replace(strFinalFileName, "", strReceiver)
strFinalFileName = Replace(strFinalFileName, "", strSubject)
strFinalFileName = CleanString(strFinalFileName)
If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
strErrorMsg = Mid(strFinalFileName, 16, 9999)
Error 1003
End If
strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251),  _
strFinalFileName)
strFullPath = strBackupPath & strFinalFileName
'Save as msg or txt?
Select Case UCase(EXM_OPT_MAILFORMAT)
Case "MSG":
strFullPath = strFullPath & ".msg"
vExtConst = olMSG
Case Else:
strFullPath = strFullPath & ".txt"
vExtConst = olTXT
End Select
'File already exists?
If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then
Error 1002
End If
'Save file
myMailItem.SaveAs strFullPath, vExtConst
'Return true as everything was successful
ProcessEmail = True
ExitScript:
Exit Function
ErrorHandler:
Select Case Err.Number
Case 1001:  'Not an email
ProcessEmail = EXM_013
Case 1002:
ProcessEmail = EXM_014
Case 1003:
ProcessEmail = strErrorMsg
Case Else:
ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
End Select
Resume ExitScript
End Function
Private Function CleanString(strData As String) As String
Const PROCNAME As String = "CleanString"
On Error GoTo ErrorHandler
'Instantiate RegEx
Dim objRegExp As Object
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Global = True
'Cut out strings we don't like
objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
strData = objRegExp.Replace(strData, "")
'Replace and cut out invalid strings.
strData = Replace(strData, Chr(9), "_")
strData = Replace(strData, Chr(10), "_")
strData = Replace(strData, Chr(13), "_")
objRegExp.Pattern = "[/\\*]"
strData = objRegExp.Replace(strData, "-")
objRegExp.Pattern = "[""]"
strData = objRegExp.Replace(strData, "'")
objRegExp.Pattern = "[:?\|]"
strData = objRegExp.Replace(strData, "")
'Replace multiple chars by 1 char
objRegExp.Pattern = "\s+"
strData = objRegExp.Replace(strData, " ")
objRegExp.Pattern = "_+"
strData = objRegExp.Replace(strData, "_")
objRegExp.Pattern = "-+"
strData = objRegExp.Replace(strData, "-")
objRegExp.Pattern = "'+"
strData = objRegExp.Replace(strData, "'")
'Trim
strData = Trim(strData)
'Return result
CleanString = strData
ExitScript:
Exit Function
ErrorHandler:
CleanString = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " &  _
PROCNAME & ")"
Resume ExitScript
End Function

Private Function GetFileDir() As String
Const PROCNAME As String = "GetFileDir"
On Error GoTo ErrorHandler
Dim ret As String
Dim lpIDList As Long
Dim sPath As String
Dim udtBI As BrowseInfo
Dim RdStrings() As String
Dim nNewFiles As Long
'Show a browse-for-folder form:
With udtBI
.lpszTitle = lstrcat(EXM_016, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList = 0 Then Exit Function
'Get the selected folder.
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
'Strip Nulls
If (InStr(sPath, Chr$(0)) > 0) Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)
'Return Dir
GetFileDir = sPath
ExitScript:
Exit Function
ErrorHandler:
GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " &  _
PROCNAME & ")"
Resume ExitScript
End Function
Anschließend erstelle eine Schaltfläche in der Menüleiste und weise diese dem Makro zu.
Übrigens damals habe ich von Sepp ein Excel Makro bekommen mit dem Man die Daten dieser gespeicherten Mails in eine Excel Tabelle auslesen kann. Siehe hier:
https://www.herber.de/forum/archiv/1208to1212/t1211643.htm#1211643
Gruß
Martin
Anzeige
AW: off topic - Outlook
21.07.2011 13:10:32
PeterO
Hallo Martin,
ist ja ein irre langer Code. Mag ihn gar nicht recht lesen (und verstehen) wollen. Wir haben hier in der Firma folgende Lösung zum Speichern von markierten Mails (immer im selben Ordner):

Private Lfn As Integer
Private Pfad As String
Sub Markierte_Mails_Kopieren()
'hier den gewünschten Pfad zum Speichern festlegen
If Dir(Environ("UserProfile") & "\Desktop\DMS", vbDirectory) = "" Then
MkDir (Environ("UserProfile") & "\Desktop\DMS")
End If
Pfad = Environ("UserProfile") & "\Desktop\DMS/"
On Error GoTo Fehler
' Variablen
Dim Ordner As MAPIFolder
Dim SelektierteMail As MailItem
Dim Selektion As Selection
Dim Anzahl_kopierte_Mails As Integer
'Objekte zuweisen
Set Ordner = Application.ActiveExplorer.CurrentFolder
Set Selektion = Application.ActiveExplorer.Selection
Anzahl_kopierte_Mails = 0
If Selektion.Count = 0 Then
MsgBox "Bitte Mails auswählen!"
Else
For Each SelektierteMail In Selektion
Mail_Speichern SelektierteMail
Anzahl_kopierte_Mails = Anzahl_kopierte_Mails + 1
Next
End If
MsgBox "Kopiervorgang beendet, " & Anzahl_kopierte_Mails & " Mails wurden in den Ordner DMS auf Ihrem Desktop kopiert"
Mails_Loeschen
Exit Sub
Fehler:
MsgBox Err.Description + " Bitte sicherstellen, dass im gewälten Ordner Mails markiert sind und der Ordner ein Mailordner ist!"
End Sub
Private Sub Mail_Speichern(ByVal Mail As Object)
Dim Betreff As String
Dim Absender As String
Dim SaveString As String
If TypeName(Mail) = "MailItem" Then
Absender = Mail.SenderName
Betreff = Mail.Subject
Betreff = Format$(Lfn, "0000") & "#" & Betreff & "#" & Absender
'Folgende Zeilen filtern alle möglichen Sonderzeichen raus, die nicht als Dateinamen  _
auftreten dürfen
Betreff = Replace(Betreff, ":", "")
Betreff = Replace(Betreff, "*", "_")
Betreff = Replace(Betreff, """", "")
Betreff = Replace(Betreff, "|", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, ">", "-")
Betreff = Replace(Betreff, "

Public Function Mails_Loeschen()
On Error GoTo Fehler
' Variablen
Dim SelektierteMail       As MailItem
Dim Selektion             As Selection
Dim Anzahl_geloeschte_Mails As Integer
'Objekte zuweisen
Set Selektion = Application.ActiveExplorer.Selection
Anzahl_geloeschte_Mails = 0
If MsgBox("Sollen die kopierten Mails jetzt aus dem Postfach gelöscht werden?" & vbCrLf &  _
vbCrLf & "Achtung, die markierten Mails werden dann dauerhaft gelöscht!", vbQuestion + vbYesNo, "Mails löschen") = vbNo Then
MsgBox "Es wurde keine Mail gelöscht!"
Else
For Each SelektierteMail In Selektion
SelektierteMail.Delete
Next
End If
Exit Function
Anzahl_geloeschte_Mails = Anzahl_geloeschte_Mails + 1
MsgBox "Es wurden " & Anzahl_geloeschte_Mails & " aus dem Postfach gelöscht!"
Fehler:
MsgBox Err.Description + " Es ist ein Fehler beim Löschen aufgetreten!"
End Function


(keine Ahnung woher der Code stammt)
Zum Abspeichern der Anhänge verwende ich folgenden Code:
http://www.ms-office-forum.net/forum/showpost.php?p=1075669&postcount=4
Funktioniert super.
Gruß Peter
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige