Code:
Option Explicit#If VBA7 Then
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private OFName As OPENFILENAME
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
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 LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
#Else
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
#End If
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
Public 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 strText As String
Dim strMail As MailItem
Dim antw, x As Integer
Dim tmp_FlagRequest
' Mail-Eingangsordner festlegen
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
' Markierter Eintrag
On Error Resume Next
' Ansicht auf Eingangsordner
'Set Application.ActiveExplorer.CurrentFolder = _
myNameSpace.GetDefaultFolder (olFolderInbox)
Set myOlExp = Outlook.ActiveExplorer
' Markierte Mails zuweisen
Set myOlSel = myOlExp.Selection
' Alle markierten Mails durchlaufen
For x = 1 To myOlSel.Count
Set MyItem = myOlSel.Item(x)
' Mail als erledigt kennzeichnen
tmp_FlagRequest = MyItem.FlagStatus
MyItem.FlagStatus = OlFlagStatus.olFlagComplete
MyItem.Save
If MyItem Is Nothing Then
MsgBox "Nichts markiert"
End If
On Error GoTo 0
' Exportieren
fkt_Export MyItem
Next x
' Aufräumen
Set MyItem = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
Set myfolder = Nothing
Set myNameSpace = Nothing
End Sub
Function fkt_Export(ByRef MyItem As MailItem)
Dim datum, Pfad, absender, Betreff, dateiname, antwort, Zeit, adresse, Text1, anvon
Dim myuser As Object
Dim ret As String
Dim antw As String
Dim sDate As Date
If MyItem Is Nothing Then Exit Function
datum = Format(MyItem.SentOn, "yyyymmdd") ' Festlegung des Datumsformats für den Dateinamen
Zeit = Format(MyItem.SentOn, "hh'mm'ss") ' Festlegung des Zeitformats für den Dateinamen
adresse = MyItem.To
absender = MyItem.SenderName
sDate = MyItem.ReceivedTime
adresse = Replace(adresse, Chr$(34), "")
adresse = Replace(adresse, ":", "_")
adresse = Replace(adresse, "<", "_")
adresse = Replace(adresse, ">", "_")
adresse = Replace(adresse, "?", "_")
adresse = Replace(adresse, "/", "_")
adresse = Replace(adresse, "\", "_")
adresse = Replace(adresse, "*", "_")
adresse = Replace(adresse, ".", ".")
adresse = Replace(adresse, "|", "-")
adresse = Replace(adresse, "[", "-")
adresse = Replace(adresse, "]", "-")
adresse = Replace(adresse, ";", "")
adresse = Replace(adresse, "'", "")
absender = Replace(absender, Chr$(34), "")
absender = Replace(absender, ":", "_")
absender = Replace(absender, "<", "_")
absender = Replace(absender, ">", "_")
absender = Replace(absender, "?", "_")
absender = Replace(absender, "/", "_")
absender = Replace(absender, "\", "_")
absender = Replace(absender, "*", "_")
absender = Replace(absender, ".", ".")
absender = Replace(absender, "|", "-")
absender = Replace(absender, "[", "-")
absender = Replace(absender, "]", "-")
absender = Replace(absender, ";", "")
absender = Replace(absender, "'", "")
Set myuser = Application.GetNamespace("MAPI").CurrentUser
If absender Like "*Schulze*" Then
anvon = "an"
Else
anvon = "von"
End If
If anvon = "an" Then
Text1 = adresse
ElseIf anvon = "von" Then
Text1 = absender
End If
Betreff = MyItem.Subject
Betreff = Replace(Betreff, Chr$(34), "")
Betreff = Replace(Betreff, ":", "_")
Betreff = Replace(Betreff, "<", "_")
Betreff = Replace(Betreff, ">", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, "/", "_")
Betreff = Replace(Betreff, "\", "_")
Betreff = Replace(Betreff, "*", "_")
Betreff = Replace(Betreff, ".", ".")
Betreff = Replace(Betreff, "|", "-")
Betreff = Replace(Betreff, "[", "-")
Betreff = Replace(Betreff, "]", "-")
Betreff = Replace(Betreff, Chr$(9), " ")
' Wenn Betreff länger als 50 Zeichen ist dann Rest löschen
If Len(Betreff) > 50 Then
Betreff = Left(Betreff, 50)
End If
' Wenn Absender länger als 50 Zeichen ist dann Rest löschen
If Len(Text1) > 50 Then
Text1 = Left(Text1, 50)
End If
dateiname = Pfad & datum & ", " & anvon & " " & Text1 & " - " & Betreff & ".msg"
ret = fkt_FileSaveAs(dateiname)
If ret <> "" Then
MyItem.SaveAs ret, olMSG
'antw = fkt_setTime(ret, sDate)
End If
End Function
Function fkt_FileSaveAs(sName) As String
'Dim sFilters As String
Dim intError As Integer
' Formattyp-Filter festlegen
Dim strAktDir
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 = strAktDir
.lpstrDefExt = "msg"
' Titel des Dialogfester festlegen
.lpstrTitle = "Datei speichern"
' Flags zum Festlegen eines bestimmten Verhaltens,
' OFN_LONGNAMES = lange Dateinamen verwenden
' OFN_OVERWRITEPROMPT = Abfrage vorm Überschreiben
.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
fkt_FileSaveAs = ""
End If
End Function
Foren auf CAD.de (alle Foren)
| 
