Hallo zusammen,
ich würde gerne eure Hilfe in Anspruch nehmen.
Ich habe ein VBA-Skript, dass die E-Mails ablegt und die Anhänge separat in einen gewünschten Ordner speichert. Nun möchte ich aber die E-Mails ohne Anhänge (Extra-Ordner) speichern.
Nachfolgend das Skript:
Public Declare Function lstrcat Lib „kernel32“ Alias „lstrcatA“ (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib „shell32“ (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib „shell32“ (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Sub CoTaskMemFree Lib „ole32.dll“ (ByVal hMem As Long)
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260
Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Sub SpeichernalsMSG()
Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Dim strBackupPath As String
Dim lngAttCount As Long, i As Long
Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder
If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende
strBackupPath = GetFileDir
Set olSelection = myExplorer.Selection
For Each myItem In olSelection
With myItem
fstTo = Mid(.To, 1, InStr(1, .To, „;“, vbTextCompare))
If fstTo = „“ Then fstTo = .To
If fstTo = „“ Then fstTo = „BCC-Empfänger“
’ Ordner der E-Mail ermitteln, um zu erkennen, ob gesendet oder empfangen wurde
Dim ordner As Outlook.MAPIFolder
Dim gesendet As Boolean
Set ordner = myItem.Parent
gesendet = False
Do Until ordner.Parent = „Mapi“
If ordner.Name = „Postausgang“ Or ordner.Name = „Outbox“ Or ordner.Name = „Gesendete Elemente“ Or ordner.Name = „Gesendete Objekte“ Or ordner.Name = „Sent Items“ Then
gesendet = True
End If
Set ordner = ordner.Parent
Loop
'Unterscheidung nach Empfangen oder Versendet
If gesendet = True Then
itemName = Format(.ReceivedTime, „yymmdd“) & „_A_“ & fstTo & „_“ & .Subject & „_“
Else
itemName = Format(.ReceivedTime, „yymmdd“) & „_E_“ & .SenderName & „_“ & .Subject & „_“
End If
'itemName = Format(.ReceivedTime, „yymmdd“) & „_“ & .SenderName & „_“ & fstTo & „_“ & .Subject & „_“
strname = IIf(Len(strBackupPath & itemName) > 255, _
Left(itemName, 255 - Len(strBackupPath)), itemName) & „.msg“
End With
'Ist Datei schon vorhanden
strtestname = strBackupPath & „“ & CleanString(strname)
myItem.SaveAs FileExists(strtestname, strBackupPath), olMSG
'Anlagen speichern
lngAttCount = myItem.Attachments.Count
If lngAttCount > 0 Then
For i = lngAttCount To 1 Step -1
With myItem.Attachments.Item(i)
'strname = IIf(Len(strBackupPath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject)
Dim itemNameBereinigt As String
itemNameBereinigt = itemName
itemNameBereinigt = CleanString(itemNameBereinigt)
strname = IIf(Len(strBackupPath & itemNameBereinigt) > 255, _
Left(itemNameBereinigt, 255 - Len(strBackupPath)), itemNameBereinigt)
strSubDir = strBackupPath & „“ & CleanString(strname)
If Dir(strSubDir, vbDirectory) = „“ Then
MkDir strSubDir
End If
’ Datei schon gespeichert
Datei = strSubDir & „“ & .FileName
geändert = False
nummer = 1
Prüfname = Datei
Zurück:
nummer = nummer + 1
If CreateObject(„Scripting.FileSystemObject“).FileExists(Prüfname) = True Then
dateiname = CreateObject(„Scripting.FileSystemObject“).GetBaseName(Datei)
dateiendung = CreateObject(„Scripting.FileSystemObject“).GetExtensionName(Datei)
dateinameneu = dateiname & " (" & nummer & „)“ & „.“ & dateiendung
Prüfname = strSubDir & „“ & dateinameneu
geändert = True
GoTo Zurück:
Else
If geändert = False Then dateinameneu = .FileName
End If
.SaveAsFile strSubDir & „“ & dateinameneu
End With
Next
Else
End If
Next
Ende:
End Sub
Private Function CleanString(strData As String) As String
strData = ReplaceChar(strData, „´“, „_“)
strData = ReplaceChar(strData, „`“, „_“)
strData = ReplaceChar(strData, „’“, „_“)
strData = ReplaceChar(strData, „{“, „(“)
strData = ReplaceChar(strData, „[“, „(“)
strData = ReplaceChar(strData, „]“, „)“)
strData = ReplaceChar(strData, „}“, „)“)
strData = ReplaceChar(strData, „/“, „-“)
strData = ReplaceChar(strData, „“, „-“)
strData = ReplaceChar(strData, „:“, „“)
strData = ReplaceChar(strData, „*“, „_“)
strData = ReplaceChar(strData, „?“, „“)
strData = ReplaceChar(strData, „“"", „_“)
strData = ReplaceChar(strData, „|“, „“)
strData = ReplaceChar(strData, „“, „“)
strData = ReplaceChar(strData, " ", „_“)
CleanString = Trim(strData)
End Function
Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String
Dim tmpChar, tmpString As String
Dim i As Long
For i = 1 To Len(strData)
tmpChar = Mid(strData, i, 1)
If tmpChar = strBadChar Then
tmpString = tmpString & strGoodChar
Else
tmpString = tmpString & tmpChar
End If
Next i
ReplaceChar = Trim(tmpString)
End Function
Public Function GetFileDir() As String
Dim ret As String
Dim lpIDList As Long
Dim sPath As String, udtBI As BrowseInfo
Dim RdStrings() As String, nNewFiles As Long
'Show a browse-for-folder form:
With udtBI
.lpszTitle = lstrcat(„Bitte wählen Sie den Ordner zum Exportieren:“, „“)
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList = 0 Then Exit Function
'Get the selected folder.
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
sPath = StripNulls(sPath)
GetFileDir = sPath
End Function
Public Function StripNulls(ByVal OriginalStr As String) As String
If (InStr(OriginalStr, Chr$(0)) > 0) Then
OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = OriginalStr
End Function
Public Function FileExists(PrüfnameMsg, SubDir As String)
On Error Resume Next
'Datei schon gespeichert
changes = False
Number = 1
Prüfname = PrüfnameMsg
Back:
Number = Number + 1
If CreateObject(„Scripting.FileSystemObject“).FileExists(Prüfname) = True Then
dateiname = CreateObject(„Scripting.FileSystemObject“).GetBaseName(Prüfname)
dateiendung = CreateObject(„Scripting.FileSystemObject“).GetExtensionName(Prüfname)
dateinameneu = dateiname & " (" & Number & „)“ & „.“ & dateiendung
Prüfname = SubDir & „“ & dateinameneu
changes = True
GoTo Back:
Else
End If
If changes = False Then
FileExists = PrüfnameMsg
Else
FileExists = Prüfname
End If
End Function
Dürfte eigentlich nicht sehr aufwändig sein, den Anhang nicht zu speicher. Wenn ich jedoch einfach nur die Funktion „Anlage speichern“ lösche, meckert er wegen dem Ende (End sub).
Schon Mal vielen Dank im Voraus!
Achilleus-28
