Outlook VBA Makro: "Speichern deluxe"

12/06/2008 - 15:02 von mail | Report spam
Hallo,

nachdem ich einiges zum obigen Thema recherchiert und probiert habe,
habe ich ein Makro gefunden und leicht angepasst. Soweit bin ich auch
sehr zufrieden. Leider stört mich bei folgendem Makro, dass ich zu
jeder zu speichernden Mail das "Speichern In - Fenster" aufgeblendet
bekomme und dieses bestàtigen muss. Besteht die Möglichkeit dies zu
umgehen oder zu automatisieren?

Vielen Dank

hier das besagte Makro
#####

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

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
' 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)
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
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, "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
sDate = myItem.ReceivedTime
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, "*", "_")
Betreff = Replace(Betreff, ".", ". ")
dateiname = Pfad & datum & " " & Zeit & " - " & absender & " - " &
Betreff
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

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 = "D:\Dokumente und Einstellungen\vonPruschak.A
\Desktop\mail"
.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
 

Lesen sie die antworten

#1 Peter Marchert
12/06/2008 - 17:58 | Warnen spam
On 12 Jun., 15:02, wrote:
Hallo,

nachdem ich einiges zum obigen Thema recherchiert und probiert habe,
habe ich ein Makro gefunden und leicht angepasst. Soweit bin ich auch
sehr zufrieden. Leider stört mich bei folgendem Makro, dass ich zu
jeder zu speichernden Mail das "Speichern In - Fenster" aufgeblendet
bekomme und dieses bestàtigen muss. Besteht die Möglichkeit dies zu
umgehen oder zu automatisieren?

Vielen Dank

hier das besagte Makro
#####

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

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
' 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)
  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
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, "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
sDate = myItem.ReceivedTime
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, "*", "_")
Betreff = Replace(Betreff, ".", ". ")
dateiname = Pfad & datum & " " & Zeit & " - " & absender & " - " &
Betreff
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

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 = "D:\Dokumente und Einstellungen\vonPruschak.A
\Desktop\mail"
  .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



Hallo,

hier ungetestet eine verkürzte Version ohne Speichern-Dialgog:

Option Explicit

Public Sub ListSaveAs()

' Definition der Variablen
Dim myItem As MailItem
Dim myfolder As MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myOlExp As Outlook.Explorer
Dim x As Long
' Mail-Eingangsordner festlegen
Set myfolder = Outlook.Session.GetDefaultFolder(olFolderInbox)
' Markierter Eintrag

On Error Resume Next

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)
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

End Sub

Function fkt_Export(ByRef myItem As MailItem)

Dim datum, Pfad, absender, Betreff, dateiname, Zeit
Dim strDir As String
Dim myuser As Object
Dim sDate As Date
If myItem Is Nothing Then Exit Function
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
sDate = myItem.ReceivedTime
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, "*", "_")
Betreff = Replace(Betreff, ".", ". ")
dateiname = Pfad & datum & " " & Zeit & " - " & absender & " - " &
Betreff

strDir = "D:\Dokumente und Einstellungen\vonPruschak.A\Desktop\mail
\"
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"

Call myItem.SaveAs(strDir & dateiname, olMSG)

End Function

Die Variable "strDir" muss geàndert werden, wenn in einen anderen Pfad
die Mails abgelegt werden sollen.

Gruß
Peter

Infos, Workshops & Software für
Outlook®: www.outlook-stuff.com

Ähnliche fragen