mail eklerini diske kaydetme

[benli58]

merhaba arkadaşlar;
ms outlook'ta gelen kutusundaki mail eklerini (.txt uzantılı dosya) sabit diskte c:\gelen dizinine kopyalayan bir makro'ya ihtiyacım var. mümkün se dizine değilde açık excel dosyasına kayıt etmesini istiyorum.

 

[benli58]

bu konuda deneyimi veya fikri olan arkadaşım yok mu?

 

[Recep İpek]

Aşağıdaki linki inceleyebilirsiniz.

http://arcanecode.files.wordpress.com/2007/02/saveattachments3.txt

 

[Recep İpek]

Örnek bir çalışmayı ekte bulabilirsiniz.

Public Sub SaveAllAttachments()
  Dim App As New Outlook.Application
  Dim Exp As Outlook.Explorer
  Dim Sel As Outlook.Items
 
  Dim AttachmentCnt As Integer
  Dim AttTotal As Integer
  Dim MsgTotal As Integer
 
  Dim outputDir As String
  Dim outputFile As String
  Dim fileExists As Boolean
  Dim cnt As Integer
 
  Dim fso As FileSystemObject
 
  Set Exp = App.ActiveExplorer
  Set Sel = Exp.CurrentFolder.Items
  Set fso = New FileSystemObject
 
  outputDir = "C:\Temp\" [COLOR=blue]'Klasör Adresi[/COLOR]
 
     For cnt = 1 To Sel.Count
      If Sel.Item(cnt).Attachments.Count > 0 Then
      MsgTotal = MsgTotal + 1
      For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
        Dim att As Attachment
        Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
        outputFile = UCase(att.FileName)
 
        If Right(outputFile, 3) = "TXT" Then
        fileExists = fso.fileExists(outputDir + outputFile)
        Do While fileExists = True
          outputFile = InputBox("The file " + outputFile _
            + " already exists in the destination directory of " _
            + outputDir + ". Please enter a new name, or hit cancel to skip this one file.", "File Exists", outputFile)
            If outputFile = "" Then
            Exit Do
          End If
          fileExists = fso.fileExists(outputDir + outputFile)
        Loop
        If fileExists = False Then
          att.SaveAsFile (outputDir + outputFile)
          AttTotal = AttTotal + 1
        End If
        End If
      Next
    End If
  Next
  Set Sel = Nothing
  Set Exp = Nothing
  Set App = Nothing
  Set fso = Nothing
 
  Dim doneMsg As String
  doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
  MsgBox doneMsg, vbOKOnly, "Save All Attachments"
   Exit Sub
ErrorHandler:
  Dim errMsg As String
  errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
  Dim errResult As VbMsgBoxResult
  errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
  Select Case errResult
    Case vbAbort
      Exit Sub
    Case vbRetry
      Resume
     Case vbIgnore
      Resume Next
  End Select
  [COLOR=blue]'NOT:[/COLOR]
[COLOR=blue]  'Referanslardan[/COLOR]
[COLOR=blue]  'Microsoft Outlook X.X Library[/COLOR]
[COLOR=blue]  'Microsoft Scripting Runtime[/COLOR]
[COLOR=blue]  'seçili olmalıdır.[/COLOR]
[COLOR=blue]  'Outlokta Inbox klasörü seçili olmalıdır.[/COLOR]
End Sub

 

[benli58]

sayın ripek yardımınız için teşekkür ederim.yanlız verdiğiniz link çalışmıyor.lütfen bu siteyi incelemek isterim.

 

[Recep İpek]

Verdiğim link bende çalışıyor.Fakat site çalışmıyor.Sanırım başka örnek kodlar da yok.Olan kodlarıda ben size göre uyarlayarak 4.mesajda yazdım.