Merhaba,
Mic.Outlook hesabımda bulunan mailleri excele aktif olarak aktarmak istiyorum.
Bunu bir VBA kodu ile yapabiliyorum fakat tüm mailleri alıyor.
Bewn ise sadece bir kullanıcıdan gelenleri alsın istiyorum.
Elinde buna uygun kod olan varmı?
Konu hakkında yardım lütfen.
Elimdeki örnek VBA kodu;
Option Explicit
Private lRow As Long, x As Date, oWS As Worksheet
Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox) '.Folders(InputBox("Maillerin bulunduğu klasörü giriniz", "BDD"))
Set oWS = ActiveSheet
x = Date
lRow = 2
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False
GetFromFolder oRootFldr
' Application.ScreenUpdating = True
Application.Calculation = lCalcMode
Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object
For Each oItem In oFldr.Items
Range("g1").Value = lRow
If TypeName(oItem) = "MailItem" Then
With oItem
' If .Subject = "Is Goremezlik Raporu" Then
oWS.Cells(lRow, 1).Value = .SenderName
oWS.Cells(lRow, 2).Value = .to
oWS.Cells(lRow, 3).Value = .cc
oWS.Cells(lRow, 4).Value = .Subject
oWS.Cells(lRow, 5).Value = .ReceivedTime
oWS.Cells(lRow, 6).Value = .body
lRow = lRow + 1
' If lRow = 10 Then Exit Sub
' End If
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub