Outlook VBA - Mailanzeige in MsgBox
23.09.2022 19:34:04
Steffen
nicht direkt Excel, aber ich hoffe hier trotzdem Hilffe zu bekommen.
Ich habe ein Makro, welches markierte Outlook-Mails in einem bestimmten Format auf der Festplatte speichert. Nun können Dateipfade mit mehr als 260 Zeichen so nicht abgelegt werden, da der Explorer diese Größenbeschränkung führt (nein, ich kann diese nicht aufheben). Das aktuelle Makro wirft mir aus, wie viele von den markierten Mails nicht abgelegt wurden. Zusätzlich wünsche ich mir, dass er mir auch (bspw. In einer MsgBox) anzeigt welche Mails das sind, damit eine manuelle Speicherung durchgeführt werden kann. Leider habe ich bisher keine gute Idee, diese in der Schleife 'zu sammeln' und dann als Liste anzuzeigen. Habt ihr eine Idee?
Danke!
P.s. Es geht um das letzte Sub. Ich musste es leider mit dem Handy anfügen. Da sind die ganzen Leerzeichen entstanden, sorry.
Dim OutAppl As Object
Dim OutItem As Object
Dim OutName As Object
Dim OutFold As Object
Dim i As Integer
Dim pfad As String
Dim kunde As String
Dim Absender As String
Dim datum As String
Dim subject As String
Dim dateiname As String
Dim Fehlercounter As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
Global StartDir As String
Public Function VerzeichnisSuchen(szDialogTitle As String, StartVerzeichnis As String) As String
Dim X As Long
Dim bi As BROWSEINFO
Dim dwIList As Long
Dim szPath As String
Dim wPos As Integer
StartDir = StartVerzeichnis
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = DummyFunc(AddressOf BrowseCallbackProc)
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
VerzeichnisSuchen = Left$(szPath, wPos - 1)
Else
VerzeichnisSuchen = ""
End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal lParam As Long, ByVal lpData As Long) As Long
Dim pathstring As String
Dim retval As Long
Select Case uMsg
Case BFFM_INITIALIZED
pathstring = StartDir
retval = SendMessage(hWnd, BFFM_SETSELECTION, ByVal CLng(1), ByVal pathstring)
End Select
BrowseCallbackProc = 0
End Function
Public Function DummyFunc(ByVal param As Long) As Long
DummyFunc = param
End Function
Public Function test() As String
test = VerzeichnisSuchen("test = VerzeichnisSuchen("Mail Speichern in:", "H:\")
End Function
Dim i, ch, astr
astr = pcstr
For i = 1 To Len(astr)
ch = Mid(astr, i, 1)
' test for "
If Asc(ch) = 34 Then Mid(astr, i, 1) = "'"
Select Case ch
Case " Mid(astr, i, 1) = "["
Case ">"
Mid(astr, i, 1) = "]"
Case "|"
Mid(astr, i, 1) = "!"
Case "?"
Mid(astr, i, 1) = "!"
Case "*"
Mid(astr, i, 1) = "#"
Case ":"
Mid(astr, i, 1) = "-"
Case "\"
Mid(astr, i, 1) = "`"
Case "/"
Mid(astr, i, 1) = "'"
Case "?"
Mid(astr, i, 1) = "!"
Case "."
Mid(astr, i, 1) = "-"
End Select
Next
parseChars = astr
End Function Sub Markierte_Mail_speichern()
Set OutAppl = GetObject(, "Outlook.Application")
Set OutName = OutAppl.GetNamespace("MAPI")
Set OutFold = Application.ActiveExplorer.Selection
Fehlercounter = 0
kunde = test
For i = 1 To OutFold.Count
Absender = OutFold.Item(i).SenderName
Absender = parseChars(Absender)
datum = Format(OutFold.Item(i).ReceivedTime, "yyyy-mm-dd-hhmm")
subject = OutFold.Item(i).subject
pfad = datum & "_" & subject
pfad = parseChars(pfad)
dateiname = kunde & "\" & pfad & " " & Absender & ".msg"
'Prüfung, ob Dateiname über 260 Zeichen
If Len(dateiname) > 260 Then
Fehlercounter = Fehlercounter + 1
Hier vielleicht ein Array?
Debug.Print Len(dateiname)
Debug.Print dateiname
Else: End If
On Error Resume Next
OutFold.Item(i).SaveAs dateiname 'Speichern
On Error GoTo 0
Next i
If Fehlercounter > 0 Then
MsgBox "Insgesamt konnten " & Fehlercounter & " von " & OutFold.Count & " Mails nicht abgelegt werden. Bitte prüfen Sie manuell!", vbInformation, "Hinweis:"
Else: End If
Set OutName = Nothing
Set OutAppl = Nothing
Set OutFold = Nothing
End Sub