bitte Code!
Gruß
Micha
Option Explicit
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private OFName As OPENFILENAME
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000&
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10
Sub myFileSaveAs()
' definition der Variablen
Dim myOLApp As Object
Dim myInspector As Inspector
Dim myItem As MailItem
Dim myuser As Object
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
On Error Resume Next
Set myOLApp = GetObject(, "Outlook.Application")
'If myOLApp Is Nothing Then 'Läuft noch nicht
' Set myOLApp = CreateObject("Outlook.Application")
'End If
Set myInspector = Application.ActiveInspector
Set myItem = myInspector.CurrentItem
Set myuser = Application.GetNamespace("MAPI").CurrentUser
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myItem = myOLApp.ActiveInspector.CurrentItem
fkt_Export myItem
Set myNameSpace = Nothing
Set myfolder = Nothing
End Sub
Sub ListSaveAs()
' definition der Variablen
Dim myOLApp
Dim myInspector As Inspector
Dim myItem As MailItem
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myOlExp As Outlook.Explorer
Dim MsgTxt As String
Dim antw, x As Integer
' Mail-Ordner
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set myOlExp = Outlook.ActiveExplorer
Set myOlSel = myOlExp.Selection
' Markierte Einträge
For x = 1 To myOlSel.Count
' MsgTxt = MsgTxt & myOlSel.Item(x).SenderName & Chr(13)
'Debug.Print MsgTxt
Set myItem = myOlSel.Item(x)
If myItem Is Nothing Then
MsgBox "Nichts markiert"
End If
On Error GoTo 0
fkt_Export myItem
Next 'x
Set myNameSpace = Nothing
Set myfolder = Nothing
End Sub
Function fkt_Export(ByRef myItem As MailItem)
Dim datum, Pfad, absender, Betreff, dateiname, antwort, Zeit
Dim myuser As Object
datum = Format(myItem.SentOn, "dd.mm.yyyy")
' Festlegung des Datumsformats für den Dateinamen
Zeit = Format(myItem.SentOn, "hh-mm-ss")
' Festlegung des Zeitformats für den Dateinamen
absender = myItem.SenderName
Set myuser = Application.GetNamespace("MAPI").CurrentUser
If absender = "" Then
absender = myuser
datum = Format(Date, "dd.mm.yyyy")
Zeit = Format(Time, "hh-mm-ss")
End If
Betreff = myItem.Subject
Betreff = Replace(Betreff, ":", "_")
Betreff = Replace(Betreff, Chr$(34), "_")
Betreff = Replace(Betreff, "<", "_")
Betreff = Replace(Betreff, ">", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, "/", "_")
Betreff = Replace(Betreff, "\", "_")
Betreff = Replace(Betreff, "*", "_")
dateiname = Pfad & absender & " - " & Betreff & " - " & datum & " " & Zeit
myItem.SaveAs fkt_FileSaveAs(dateiname), olMSG
On Error GoTo fehler
fehler:
End Function
Function fkt_FileSaveAs(sName) As String
'Dim sFilters As String
Dim intError As Integer
' Formattyp-Filter festlegen
With OFName
'Setzt die Größe der OPENFILENAME Struktur
.lStructSize = Len(OFName)
'Der Window Handle ist bei VBA fast immer &O0
.hwndOwner = &O0
' Formattyp-Filter setzen
.lpstrFilter = "Nachrichtenformat (*.msg)"
' Buffer für Dateinamen erzeugen
.lpstrFile = sName & Space$(1024) & vbNullChar & vbNullChar
' Maximale Anzahl der Dateinamen-Zeichen
.nMaxFile = Len(.lpstrFile)
' Buffer für Titel erzeugen
.lpstrFileTitle = sName
' Maximale Anzahl der Titel-Zeichen
.nMaxFileTitle = 255
' Anfangsverzeichnis vorgeben
.lpstrInitialDir = "c:\temp"
.lpstrDefExt = ".msg"
' Titel des Dialogfester festlegen
.lpstrTitle = "Datei speichern"
' Flags zum Festlegen eines bestimmten Verhaltens,
' OFN_LONGNAMES = lange Dateinamen verwenden
' OFN_OVERWRITEPROMPT = Abfrage vorm =DCberschreiben
.flags = OFN_LONGNAMES Or OFN_OVERWRITEPROMPT
End With
' API aufrufen und evtl. Fehler abfangen
intError = GetSaveFileName(OFName)
If intError <> 0 Then
fkt_FileSaveAs = Left(OFName.lpstrFile, _
InStr(1, OFName.lpstrFile, Chr(0)) - 1)
ElseIf intError = 0 Then
' Abbruch durch Benutzer oder Fehler
End If
End Function
'----------------
myItem.SaveAs fkt_FileSaveAs(dateiname), olMSG
On Error GoTo fehler
fehler:
Warum nicht:
Oder die weniger feine Methode:
On Error Resume Next
myItem.SaveAs fkt_FileSaveAs(dateiname), olMSG
Bei API gibt es keine abzufangenden Fehler:-(
myItem.SaveAs fkt_FileSaveAs(dateiname), olMSG
On Error GoTo fehler
fehler:
Warum nicht:
Oder die weniger feine Methode:
On Error Resume Next
myItem.SaveAs fkt_FileSaveAs(dateiname), olMSG
Bei API gibt es keine abzufangenden Fehler:-(