Forum

Veri aktarımı;
 
Bildirimler
Hepsini Temizle

Veri aktarımı;

2 Yazılar
2 Üyeler
0 Likes
763 Görüntüleme
(@ibrahimkurtoglu)
Gönderiler: 2
New Member
Konu başlatıcı
 

Merhaba,

Aşağıda yer alan makroda mail hesabımdaki mailleri excele aktarıyor,

Ben sadece belirleyeceğim klasör yada gönderenin maillerini almasını istiyorum.

Ayrıca bunu otomatik olarak yapsın istiyorum.

Bunu düzeltebilecek arkadaşımız varmı acaba,

Yardımcı olursanız sevinirim.

 

 

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

 
Gönderildi : 08/04/2016 21:47

(@GokhanDOGAN)
Gönderiler: 780
Prominent Member
 

Selam,

filtreleri koda ekleyip işartlerdim bu bu line lar üzerinde oynayabilirsin aşağıdaki linkte objelerin kabul ettiği filtre türleri var. 

 

https://msdn.microsoft.com/VBA/Outlook-VBA/articles/items-restrict-method-outlook

 

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)  'oldFolderInbox u silip, inbox'da var olan istediğin bi klasörün adını yazabilirsin'

Set myItems = oRootFldr.Items

 Set myRestrictItems = myItems.Restrict("[FirstName] = 'GOKHAN' AND [LastName] = 'DOGAN'")  'ISIM SOYAD FILTERSI'

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 myRestrictItems.Items 'FILTRE'DEN DONEN OBJELER UZERINDE DONGU' 
Range("g1").Value = lRow
If TypeName(oItem) = "MailItem" Then 
With oItem
' If .Subject = "Is Goremezlik Raporu" Then 'bu filtreyi yukarıya taşıyıp orada uygula.'
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

 

 

 

kolay gelsin.

 
Gönderildi : 29/07/2017 15:27

Paylaş: