Ciao silent_bob83
versuchs mal mit folgendem Code: (stammt nicht von mir)
… und noch ein guter link ein .com Bibliothek
http://www.dimastr.com/redemption/
lg
gery
Sub mail_save_backup()
'Variablendeklaration Outlook
Dim myOlExp As Outlook.Explorer
Dim myOlApp As New Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myItem As MailItem
'Variablendeklaration Zahlen
Dim AnzEintraege As Integer
Dim i As Integer
Dim Email As Integer
Dim a As Integer
Dim lAttCount As Long
'Variablendeklaration Strings
Dim strBackupPath As String
Dim strAttNames As String
Dim Dateiendung As String
Dim SaveName As String
Dim MailName As String
Dim datname As String
Set myOlExp = myOlApp.ActiveExplorer
'Ablagepfad festlegen
strBackupPath = GetFileDir
If strBackupPath = „“ Then Exit Sub
'Dummytabelle zum schreiben öffnen
Workbooks.Open FileName:=„h:\dummy.xls“
'Excel soll immer weitermachen, egal welcher Fehler
On Error Resume Next
’ Überschriften
[A1].Value = „Owner“
[B1].Value = „Progress Status“
[C1].Value = „Customer“
[D1].Value = „RTN“
[E1].Value = „Received Time“
[f1].Value = „Technology“
[G1].Value = „Key Words“
[H1].Value = „Key Subject“
[I1].Value = „Erhalten“
[J1].Value = „Attachments“
[K1].Value = „Subject“
'Überschriften „fett“ formatieren
Rows(1).Font.Bold = True
'Setzen der Variable als Outlook Application; Zugriff auf Outlookordner „Customer Support“
Set OLF = GetObject("", „Outlook.Application“) _
.GetNamespace(„MAPI“) _
.Folders(„Öffentliche Ordner“) _
.Folders(„Favoriten“) _
.Folders(„Customer Support“)
'Setzen der Variable -> es sollen alle Nachrichten Custommer Support gezählt werden
AnzEintraege = OLF.Items.Count
'Setzen der Variablen auf ‚0‘
i = 0
Email = 0
'Beginn Schleifendurchlauf (Schleife 1) -> die Variable ‚i‘ läuft bis zur Anzahl der EMails
While i 0 Then
'Durchzählschleife für alle Anhänge
For a = lAttCount To 1 Step -1
'Stringvariable leeren
strAttNames = „“
'Schleife zum Dateispeichern
With OLF.Items(i).Attachments.Item(a)
'Anhangsname und Endung auslesen
strAttNames = CreateObject(„Scripting.FileSystemObject“).GetBaseName(.FileName)
Dateiendung = CreateObject(„Scripting.FileSystemObject“).GetExtensionName(.FileName)
'Anhänge speichern
SaveName = strBackupPath & „“ & _
.UserProperties(„Own“).Value & „“ & _
.UserProperties.Item(„Progress Status“).Value & „“ & _
.UserProperties(„Customer“).Value & „“ & _
.UserProperties.Item(„Request Tracking Number“).Value & „“ & _
CleanString(strAttNames) & „.“ & Dateiendung
.SaveAsFile SaveName
End With
Next
End If
olsubject = OLF.Items(i).Subject
'Abspeichern der Nachricht
MailName = IIf(Len(strBackupPath & „“ & _
.UserProperties(„Own“).Value & „“ & _
.UserProperties.Item(„Progress Status“).Value & „“ & _
.UserProperties(„Customer“).Value & „“ & _
.UserProperties.Item(„Request Tracking Number“).Value & „“ & _
olsubject) > 255, Left(olsubject, 255 - Len(strBackupPath)), olsubject) & „.msg“
.SaveAs strBackupPath & „“ & _
.UserProperties(„Own“).Value & „“ & _
.UserProperties.Item(„Progress Status“).Value & „“ & _
.UserProperties(„Customer“).Value & „“ & _
.UserProperties.Item(„Request Tracking Number“).Value & „“ & _
CleanString(MailName), olMSG
'Zweite Schleife ende
End With
'Erste Schleife ende
Wend
'Variable zurücksetzen
Set OLF = Nothing
'Breite der Spalten anpassen
Columns(„A:K“).AutoFit
'Dateiname zum speichern wird abgefragt
datname = InputBox(„Geben sie Einen Dateinamen für die Übersichtsdatei an“, „Save“, „Übersicht“)
'Datei wird gespeichert
ActiveWorkbook.SaveAs FileName:=strBackupPath & „“ & datname & „.xls“
'Die Statuszeile wird wieder ausgeschaltet
Workbooks(„dummy.xls“).Close (False)
Workbooks(text & „.xls“).Close (False)
MsgBox „Ende“
End Sub