Etiket arşivi: save

outlook da ekleri toplu kaydetme

Merhaba arkadaşlar uzun uğraşlardan sonra bulduğum kodları sizinle paylaşmak istiyorum.
Aşağıdaki kodları makrodan yeni modül oluşturarak içine yapıştırın ve kaydedin.
Makroyu çalıştırdığınızda sizden ekleri nereye çıkarmak istediğinizi soracak ekleri çıkaracağı dosyayı seçmeniz yeterli
uyarıları dikkate almayın. Arkadaşa şaka olsun diye yazdım.

Option Explicit

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 = "<b>Ramazan Burdaydı :)</b>: " & filesRemoved & "<br><br>"
                   
                    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