outlook da ekleri toplu kaydetme

Public Sub ExportAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long, lngCount As Long
Dim filesRemoved As String, fName As String, strFolder As String, saveFolder As String, savePath As String
Dim alterEmails As Boolean, overwrite As Boolean
Dim result
Dim sayi As Integer

saveFolder = BrowseForFolder("Select the folder to save attachments to.")
If saveFolder = vbNullString Then Exit Sub

result = MsgBox("Emaillerini silecegim hala benimle oynamak istiyor musun? " & vbNewLine & _
"(Saka yaptim :) )", vbYesNo + vbQuestion)
alterEmails = (result = vbYes)

Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection

For Each objMsg In objSelection
If objMsg.Class = olMail Then
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
filesRemoved = ""
For i = lngCount To 1 Step -1
fName = objAttachments.Item(i).FileName
savePath = saveFolder & "\" & fName
overwrite = False
While Dir(savePath) <> vbNullString And Not overwrite
sayi = Rnd(10000)

Dim newFName As String
newFName = CStr(sayi) + fName
If newFName = vbNullString Then GoTo skipfile
If newFName = fName Then overwrite = True Else fName = newFName
savePath = saveFolder & "\" & fName
Wend

objAttachments.Item(i).SaveAsFile savePath

skipfile:
Next i

If alterEmails Then
filesRemoved = "Ramazan Burdaydı :): " & filesRemoved & "

"

Dim objDoc As Object
Dim objInsp As Outlook.Inspector
Set objInsp = objMsg.GetInspector
Set objDoc = objInsp.WordEditor

objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody
objMsg.Save
End If
End If
End If
Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Function formatSize(size As Long) As String
Dim val As Double, newVal As Double
Dim unit As String

val = size
unit = "bytes"

newVal = Round(val / 1024, 1)
If newVal > 0 Then
val = newVal
unit = "KB"
End If
newVal = Round(val / 1024, 1)
If newVal > 0 Then
val = newVal
unit = "MB"
End If
newVal = Round(val / 1024, 1)
If newVal > 0 Then
val = newVal
unit = "GB"
End If

formatSize = val & " " & unit
End Function

'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error handler if found
'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else: GoTo Invalid
End Select

Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = vbNullString
End Function

Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt)

On Error Resume Next
BrowseForFile = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error handler if found
'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else: GoTo Invalid
End Select

Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFile = vbNullString
End Function