Genel klasörlerdeki eklerin dosya isimlerini ayıklamak ve kolay analiz için bunları excel dosyasına yapıştırmak istiyorum.Outlook Ekleri Gerekiyor Dosya adları (veya yalnızca uzantılar) Excel'e seçili e-postalar için dışa aktarılan numaralar
Aşağıdaki kodum var, ancak yalnızca 1 e-postanın ayrıntılarını seçiyor.
Nerede yanlış olduğunu anlamak isterim.
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim j As Long
Dim i As Integer
Dim Report As String
Dim attachment As attachment
Dim obj As Object
Dim strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
' Process the message record
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
Set myAttachments = olItem.Attachments
'collect the fields
Next
For Each Selection In Selection
If Selection.Class = olMail Then
End If
For Each attachment In olItem.Attachments
Report = strColC & GetAttachmentInfo(attachment)
strColB = olItem.Attachments.Count
strColD = olItem.SenderEmailAddress
strColE = olItem.Categories
strColF = olItem.ReceivedTime
'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = Report
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
Next
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Public Function GetAttachmentInfo(attachment As attachment)
On Error GoTo On_Error
Dim Report
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
GetAttachmentInfo = ""
Report = strColA & "Display Name: " & attachment.DisplayName
Report = strColC & "File Name: " & attachment.filename
GetAttachmentInfo = Report
Exiting:
Exit Function
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Function
(1) Eğer tutarlı bir şekilde girinti yaparsanız, makrolarınızı ayıklamak çok daha kolay olacaktır. (2) Bana göre, Eklentilerimin eklerini çıkaran döngü, Eklentileri ayarlayan döngü içinde değil. 'Her bir ek için olItem.Attachments' altındaki 'myAttachments = olItem.Attachments' değerini ayarlamanız gerekir. (3) Bu eklere erişmeden önce bir öğenin ekleri olup olmadığını kontrol etmiyorsunuz. OlItem.Attachments.Count = 0' ise bu kodun başarısız olmasını beklerim. –
Merhaba Tony, sen muhteşem efendim !, Ben birçok hata ayıklama ve çözebilir biliyorum, sorun zaman eksikliği, ben operasyonlardan ve birçok operasyonel faaliyetleri yönetmek zorunda. Ben işleri daha kolay yapmaya çalışıyorum bu yüzden vba makrolarını deniyorum. Çok sabırlı olduğun ve soruları cevapladığın için teşekkür ederim. Yeniden başım belaya giriyor, değişiklikleri istediğim gibi yaptım, ancak e-postada 1'den fazla ek varsa, bu kodun 1'den fazla dosya alabilmesi için ekleri listesinde en fazla dosya olan 1 dosya adını aldım isim –