Read outlook emails copy to excel.

[sravanmonty]

Hello Experts.

Required urgent help

Attached the working file which is working great at home pc as outlook 2013 and server is SMPT/POP...and the same code not working in office as outlook 2013 is on exchange server..

Not really sure how different if outlook 2013 is connect to Exchange server and outlook 2013 is connected to SMPT/POP...if so help me in modifing the code.

Hope am not confusing...Please let me know if you have any questions..

[TheSilkCode]

Could you please paste the code so we can see it?

[sravanmonty]

Here is the code...Please do needful

Option ExplicitDim n As Long
Sub Get_data()
     
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim Date1, Date2
    Date1 = "01/20/2017"


    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
     n = 2
    Call Get_Emails(olFolder, Date1)
     
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olApp = Nothing
    Set olNS = Nothing
End Sub
Sub Get_Emails(olfdStart As Outlook.MAPIFolder, Date1)
    Dim olFolder As Outlook.MAPIFolder
    Dim olObject As Object
    Dim olMail As Outlook.MailItem
    Dim Recivedt As Date
     
    For Each olObject In olfdStart.Items
        If TypeName(olObject) = "MailItem" Then
            
            If olObject.ReceivedTime <= Date1 Then
                n = n + 1
                Set olMail = olObject
                'Sno
                Cells(n, 1) = n
                'Universal id
                Cells(n, 2) = olMail.ConversationID
                'Email id
                Cells(n, 3) = olMail.SenderEmailAddress
                
                'Date and time workings
                Cells(n, 4) = olMail.ReceivedTime
                
                'Size
                Cells(n, 6) = olMail.Size
                
                'Subject
                Cells(n, 7) = olMail.Subject
                
            End If
        End If
    Next
    Set olMail = Nothing
    Set olFolder = Nothing
    Set olObject = Nothing
End Sub

[sravanmonty]

Hello

As discussed , which is working great at home pc as outlook 2013 and server is SMPT/POP...and the same code not working in office as outlook 2013 is on exchange server. Not really sure is that the problem.

Error at :Cells(n, 3) = olMail.SenderEmailAddress

[sravanmonty]

Guys

Any update on my query!!

[Kenneth Hobs]

Make sure that outlook is open when you run it.

[sravanmonty]

Hello Kenneth Hobs...

Thanks for your quick response..Outlook is opened when running macro.

As discussed , which is working great at home pc as outlook 2013 and server is SMPT/POP...and the same code not working in office as outlook 2013 is on exchange server. Not really sure is that the problem.

Error at :Cells(n, 3) = olMail.SenderEmailAddress

Please help..

[Kenneth Hobs]

Have you tried:

Debug.Print Cells(n, 3)
Debug.Print olMail.SenderEmailAddress

Check VBE's Immediate window after a run to see the result of Debug.Print.

Since I don't use Exchange anymore, I have no way to test.

Some of these concepts might help:
'http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email

Private Function GetSmtpAddress(ByVal item As Outlook.MailItem) As StringDim sAddress As String
Dim recip As Outlook.Recipient
Dim exUser As Outlook.ExchangeUser
Dim oOutlook As Outlook.Application
Dim oNS As Outlook.Namespace


    Set oOutlook = New Outlook.Application
    Set oNS = oOutlook.GetNamespace("MAPI")
    If UCase$(item.SenderEmailType) = "EX" Then
        Set recip = oNS.CreateRecipient(item.SenderEmailAddress)
        Set exUser = recip.AddressEntry.GetExchangeUser()
        sAddress = exUser.PrimarySmtpAddress
    Else
        sAddress = item.SenderEmailAddress
    End If
    GetSmtpAddress = sAddress
    Set oNS = Nothing
    Set oOutlook = Nothing
End Function

or
https://www.experts-exchange.com/que...tlook-VBA.html

[Kenneth Hobs]

PM's that relate to a thread should be contained in that thread. I don't know how to help more other than post 8. It is up to you to try the Debug.Print troubleshooting as I said. Paste the results of the Immediate window after a run if it makes no sense.

Dim n As Long

Sub Get_data()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim Date1, Date2
    Date1 = "01/20/2017"
     
     
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    n = 2
    Call Get_Emails(olFolder, Date1)
     
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olApp = Nothing
    Set olNS = Nothing
End Sub


Sub Get_Emails(olfdStart As Outlook.MAPIFolder, Date1)
    Dim olFolder As Outlook.MAPIFolder
    Dim olObject As Object
    Dim olMail As Outlook.MailItem
    Dim Recivedt As Date
     
    For Each olObject In olfdStart.Items
        If TypeName(olObject) = "MailItem" Then
             
            If olObject.ReceivedTime <= Date1 Then
                n = n + 1
                Set olMail = olObject
                 'Sno
                Cells(n, 1) = n
                 'Universal id
                Cells(n, 2) = olMail.ConversationID
                 'Email id
                 
Debug.Print GetSmtpAddress(olObject), "GetSmtpAddress"
Debug.Print Cells(n, 3).Value, "Cells(n, 3).value"
Debug.Print olMail.SenderEmailAddress, "olMail.SenderEmailAddress"
                 
                Cells(n, 3) = olMail.SenderEmailAddress
                 
                 'Date and time workings
                Cells(n, 4) = olMail.ReceivedTime
                 
                 'Size
                Cells(n, 6) = olMail.Size
                 
                 'Subject
                Cells(n, 7) = olMail.Subject
                 
            End If
        End If
    Next
    Set olMail = Nothing
    Set olFolder = Nothing
    Set olObject = Nothing
End Sub


'http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email
Private Function GetSmtpAddress(ByVal item As Outlook.MailItem) As String
    Dim sAddress As String
    Dim recip As Outlook.Recipient
    Dim exUser As Outlook.ExchangeUser
    Dim oOutlook As Outlook.Application
    Dim oNS As Outlook.Namespace
     
     
    Set oOutlook = New Outlook.Application
    Set oNS = oOutlook.GetNamespace("MAPI")
    If UCase$(item.SenderEmailType) = "EX" Then
        Set recip = oNS.CreateRecipient(item.SenderEmailAddress)
        Set exUser = recip.AddressEntry.GetExchangeUser()
        sAddress = exUser.PrimarySmtpAddress
    Else
        sAddress = item.SenderEmailAddress
    End If
    GetSmtpAddress = sAddress
    Set oNS = Nothing
    Set oOutlook = Nothing
End Function

[sravanmonty]

Still no luck Kenneth...Please help


Error : Not Supported.

Debug.Print GetSmtpAddress(olObject), "GetSmtpAddress"
Debug.Print Cells(n, 3).Value, "Cells(n, 3).value"
Debug.Print olMail.SenderEmailAddress, "olMail.SenderEmailAddress"