|
Public zaehler As Integer
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Const olTXT = 0 'um den mailtext in text datei zu speichern
'----------------------folder browsing Steuerelement
Dim AppShell As Object
Dim BrowseDir As Variant
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen für Ihre Anhänge.", &H1000, 17)
On Error Resume Next
Ordnername = BrowseDir.Items().Item().Path
UserForm1.TextBox5 = Ordnername
'-----------------doppel backslash entfernen C:\\ = C:\
Dim StrText2 As String
StrText2 = Ordnername
'StrText2 = Replace("\\", "\") 'um c:\\ doppel backslash zu entfernen '''''''''''''''vb.net
StrText2 = Replace(StrText2, "\\", "\") ''''''''''''''''''''''''''''''vba
Ordnername = StrText2
'-----------------doppel backslash entfernen C:\\ = C:\ ende
'----------------------folder browsing Steuerelement
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
strFolderpath = Ordnername & ""
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
'strFolderpath = strFolderpath & "Attachments"
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection 'jedes markierte email loop
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
'------------------------Ein Ordner pro email-----------------------------
'----------------------------Ordner vorher erstellen und mit email name
Dim neuerOrdner As String
Dim Datumzeit As String
zaehler = zaehler + 1
Datumzeit = Format(Now, "ddMMyyyy_HHmmss")
'neuerOrdner = strFolderpath & objAttachments.Item(i).DisplayName
'neuerOrdner = strFolderpath & objMsg.SenderName & " (" & objMsg.SenderEmailAddress & ")"
'neuerOrdner = strFolderpath & "" & objMsg.SenderName
'neuerOrdner = strFolderpath & "" & objMsg.SenderName & "_" & Datumzeit 'mit datum und zeit am schluss '''''was
'neuerOrdner = strFolderpath & "\" & objMsg.SenderName & "_" & Datumzeit 'mit datum und zeit am schluss '''privat ''''''''''achtung
neuerOrdner = strFolderpath & "\" & objMsg.SenderName & "_" & Datumzeit & "_" & zaehler 'mit datum und zeit am schluss '''privat
MkDir (neuerOrdner)
'strFile = neuerOrdner '& "\" & objAttachments.Item(i).FileName 'achtung vorher | strFile wird nur für email body Text verendet
'strFile = neuerOrdner & "\" & objAttachments.Item(i).FileName 'achtung strFile wird nur für email body Text verendet
'----------------------------Ordner vorher erstellen und mit email name ende
'------------------------Ein Ordner pro email----------------------------- ende
objMsg.SaveAs neuerOrdner & "\" & objMsg.SenderName & ".txt", olTXT 'um den mailtext in text datei zu speichern
If lngCount > 0 Then 'jeder markierter Anhang loop
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
'strFile wird nur für body Text, text in email
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
'strFile = strFolderpath & strFile 'achrung vorher
strFile = strFolderpath & "\" & strFile
strFile = neuerOrdner & "\" & objAttachments.Item(i).FileName 'achtung strFile wird nur für email body Text verendet
'objAttachments.Item(i).SaveAsFile strFile
'objAttachments.Item(i).SaveAsFile neuerOrdner & "" & objAttachments.Item(i).FileName
'objAttachments.Item(i).SaveAsFile neuerOrdner & "" & objAttachments.Item(i).FileName
' Save the attachment as a file.
'objAttachments.Item(i).SaveAsFile strFile
objAttachments.Item(i).SaveAsFile neuerOrdner & "\" & objAttachments.Item(i).FileName ''''''''''''''''''privat
'---------------------------------------------------------
'---------------------------------------Anhänge löschen
' Delete the attachment.
'objAttachments.Item(i).Delete
'---------------------------------------Anhänge löschen ende
'----------------------------------------------------------------
'-----------------------------------------------------------------------------------
'--doppel backlslash entfernen C:\\ = C:\ wenn Root gewählt wird z. B C:\
'------------------------------------------------------------------------------------
Dim StrText3 As String
StrText3 = strFile
'StrText2 = Replace("\\", "\") 'um c:\\ doppel backslash entfernen ''vb.net
StrText3 = Replace(StrText3, "\\", "\") ''''''''''''''''''''''''''''''vba
strFile = StrText3
'----------------------------------------------------------------------------------------
'--doppel backlslash entfernen C:\\ = C:\ ende wenn Root gewählt wird z. B C:\
'-----------------------------------------------------------------------------------------
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
'objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
'objMsg.Body = vbCrLf & "Die Datei(en) wurden hier abgelegt " & strDeletedFiles & vbCrLf & objMsg.Body
objMsg.Body = vbCrLf & "Die Datei(en) wurden hier abgelegt --> " & neuerOrdner & strDeletedFiles & vbCrLf & objMsg.Body
Else
'objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
'objMsg.HTMLBody = "<p>" & "Die Datei(en) wurden hier abgelegt " & strDeletedFiles & "</p>" & objMsg.HTMLBody
objMsg.HTMLBody = "<p>" & "Die Datei(en) wurden hier abgelegt --> " & neuerOrdner & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
|
