ÇözümPark'a hoş geldiniz. Oturum Aç | Üye Ol
 
Ana Sayfa Makale Video Forum Resimler Dosyalar Etkinlik Hizmetlerimiz Biz Kimiz

Veri aktarımı;

Son Mesajınız 07-29-2017, 12:27 Gokhan DOGAN tarafından gönderildi. 1 yanıt.
Mesajları Sırala: Önceki Sonraki
  •  04-08-2016, 18:47 488673

    Veri aktarımı;

    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

  •  07-29-2017, 12:27 516988 Cevap 488673

    Cevap : Veri aktarımı;

    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.


    Information is not knowledge. A.Einstein
RSS haberlerini XML olarak görüntüle