?
Solved

Outlook VBA Code - Needs Modified

Posted on 2011-03-08
12
Medium Priority
?
532 Views
Last Modified: 2012-08-13
I found this code on EE which is very useful.  But I need a slight modification to it.  Is there a way to add a box that will allow you to choose which folders it extracts this information from?

The link below is to the original question.

http://www.experts-exchange.com/Programming/Languages/.NET/Q_24056866.html?sfQueryTermInfo=1+10+30+export+inbox+vba
0
Comment
Question by:Brad Sims, CCNA
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 6
12 Comments
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 35071858
Sorry, original code posted.
Sub Email4Excel()
' Requires excel object library to be added to the outlook VBA references
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim mai As Object
Dim xlapp As Object
Dim xlwb As Object
Dim xlws As Object
Dim xlpath As String
Dim xlBook As String
Dim xlSheet As String
Dim maiInspector As Outlook.Inspector
Dim xlIsOpen As Boolean
 
    #If cbPC = True Then
        xlpath = "C:\Users\Chris\Experts Exchange"
        xlBook = "deleteme.xls"
        xlSheet = "Sheet1"
    #Else
        xlpath = "C:\"
        xlBook = "random.xls"
        xlSheet = "Sheet1"
    #End If
    
    On Error Resume Next
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
'    Set myfolder = objNS.PickFolder
    Set myfolder = objNS.Session.GetDefaultFolder(6)
                   
    Set xlapp = GetObject(, "Excel.Application")
    xlIsOpen = (Not xlapp Is Nothing)
    If xlapp Is Nothing Then Set xlapp = CreateObject("Excel.application")
    ' fileExists modifies trims path and ensures a trailing slash
    If FileExists1(xlpath, xlBook) Then
        On Error Resume Next
        Set xlwb = xlapp.Workbooks(xlBook)
        On Error GoTo 0
        If xlwb Is Nothing Then Set xlwb = xlapp.Workbooks.Open(xlpath & xlBook)
        If xlws Is Nothing Then Set xlws = xlwb.Worksheets(xlSheet)
    Else
         Set xlwb = xlapp.Workbooks.Add
         xlwb.SaveAs FileName:=(xlpath & xlBook)
         If xlws Is Nothing Then Set xlws = xlwb.Worksheets(xlSheet)
    End If
    xlws.Cells.Clear
    xlws.Range("A1") = "Sender Email"
    xlws.Range("B1") = "Sender Name"
    For Each mai In myfolder.items
        If mai.Class = olMail Then
           On Error GoTo assumeEncrypted
               On Error GoTo inspectMai
               xlws.Range("A" & xlws.Rows.count).End(xlUp).Offset(1, 0) = mai.SenderEmailAddress
               xlws.Range("B" & xlws.Rows.count).End(xlUp).Offset(1, 0) = mai.SenderName
           On Error GoTo assumeEncrypted
        End If
        GoTo assumeEncrypted
inspectMai:
    Set maiInspector = mai.GetInspector
    maiInspector.Activate
    Stop
    If Not maiInspector Is Nothing Then maiInspector.Close (olDiscard)
    Err.Clear
assumeEncrypted:
    Next
    xlws.Columns("A:B").EntireColumn.AutoFit
    GoTo exiat
 
    
exiat:
    If Not xlapp Is Nothing Then
        xlapp.DisplayAlerts = False
        If Not xlwb Is Nothing Then xlwb.Save
        If Not xlwb Is Nothing And Not xlIsOpen Then xlwb.Close
        xlapp.DisplayAlerts = True
        Set xlapp = Nothing
    End If
Set objNS = Nothing
Set olApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Public Function FileExists1(ByRef strFolder, strFilename) As Boolean
    FileExists1 = False
    strFolder = Replace(strFolder, Chr(160), " ")
    strFolder = Trim(strFolder)
    If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
    If Len(Dir(strFolder & strFilename)) > 0 Then FileExists1 = True
End Function

Open in new window

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35071972
You already choose the root folder ... do you want to select each folder as to whether to include it?

Chris
0
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 35071993
Yes.  I have two accounts setup in Outlook.  Even though I am in the "other" folder, the code still only pulls what is in the primary account's inbox.
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35072043
Ah not so much folder pick more of an account pick ... would that be right?

Chris
0
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 35072124
I can choose the other account just like a folder, so I believe that will work.  Plus if we choose an account, won't it pull all folders from that account?  

I only want to pull the Inbox from the other account.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35072503
How about this?

Chris
Sub Email4Excel()
' Requires excel object library to be added to the outlook VBA references
Dim olApp As Object
Dim objNS As Object
Dim myfolder As Object
Dim mai As Object
Dim xlapp As Object
Dim xlwb As Object
Dim xlws As Object
Dim xlpath As String
Dim xlBook As String
Dim xlSheet As String
Dim maiInspector As Object
Dim xlIsOpen As Boolean
Dim acct As Object
 
    #If cbPC = True Then
        xlpath = "C:\Users\Chris\Experts Exchange"
        xlBook = "deleteme.xls"
        xlSheet = "Sheet1"
    #Else
        xlpath = "C:\"
        xlBook = "random.xls"
        xlSheet = "Sheet1"
    #End If
    
    On Error Resume Next
    Set olApp = CreateObject("Outlook.Application")
    Set acct = getPST(olApp)
    Set objNS = acct.session
'    Set myfolder = objNS.PickFolder
    Set myfolder = objNS.session.GetDefaultFolder(6)
                   
    Set xlapp = GetObject(, "Excel.Application")
    xlIsOpen = (Not xlapp Is Nothing)
    If xlapp Is Nothing Then Set xlapp = CreateObject("Excel.application")
    ' fileExists modifies trims path and ensures a trailing slash
    If FileExists1(xlpath, xlBook) Then
        On Error Resume Next
        Set xlwb = xlapp.Workbooks(xlBook)
        On Error GoTo 0
        If xlwb Is Nothing Then Set xlwb = xlapp.Workbooks.Open(xlpath & xlBook)
        If xlws Is Nothing Then Set xlws = xlwb.Worksheets(xlSheet)
    Else
         Set xlwb = xlapp.Workbooks.Add
         xlwb.SaveAs Filename:=(xlpath & xlBook)
         If xlws Is Nothing Then Set xlws = xlwb.Worksheets(xlSheet)
    End If
    xlws.Cells.Clear
    xlws.Range("A1") = "Sender Email"
    xlws.Range("B1") = "Sender Name"
    For Each mai In myfolder.items
        If mai.Class = olmail Then
           On Error GoTo assumeEncrypted
               On Error GoTo inspectMai
               xlws.Range("A" & xlws.Rows.Count).End(xlUp).Offset(1, 0) = mai.SenderEmailAddress
               xlws.Range("B" & xlws.Rows.Count).End(xlUp).Offset(1, 0) = mai.SenderName
           On Error GoTo assumeEncrypted
        End If
        GoTo assumeEncrypted
inspectMai:
    Set maiInspector = mai.GetInspector
    maiInspector.Activate
    Stop
    If Not maiInspector Is Nothing Then maiInspector.Close (olDiscard)
    Err.Clear
assumeEncrypted:
    Next
    xlws.Columns("A:B").EntireColumn.AutoFit
    GoTo exiat
 
    
exiat:
    If Not xlapp Is Nothing Then
        xlapp.DisplayAlerts = False
        If Not xlwb Is Nothing Then xlwb.Save
        If Not xlwb Is Nothing And Not xlIsOpen Then xlwb.Close
        xlapp.DisplayAlerts = True
        Set xlapp = Nothing
    End If
Set objNS = Nothing
Set olApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Public Function FileExists1(ByRef strFolder, strFilename) As Boolean
    FileExists1 = False
    strFolder = Replace(strFolder, Chr(160), " ")
    strFolder = Trim(strFolder)
    If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
    If Len(Dir(strFolder & strFilename)) > 0 Then FileExists1 = True
End Function

Function getPST(olkapp As Object) As Object
Dim olkAccount As Object
Dim intIndex As Integer
Dim chIndex As String
Dim strMessage As String

    For intIndex = 1 To olkapp.session.Accounts.Count
        Set olkAccount = olkapp.session.Accounts.Item(intIndex)
        strMessage = strMessage & intIndex & " = " & olkAccount.DisplayName & vbLf
    Next
    chIndex = InputBox("Select Account using the index number:" & vbCrLf & vbCrLf & strMessage, "Select Account")
    If IsNumeric(chIndex) Then
        If chIndex >= 1 And chIndex <= olkapp.session.Accounts.Count Then
            Set getPST = olkapp.session.Accounts(chIndex)
        Else
            Set getPST = olkapp.session.Accounts(1)
        End If
    End If

End Function

Open in new window

0
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 35072618
It lets me pick the account, but then it gives me a Run-Time Error '91'.  I have attached a screenshot.
Run-time-error.jpg
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35072639
Which line errors out?

Chris
0
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 35072654
Guess that would help...sorry.

For Each mai In myfolder.Items
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 2000 total points
ID: 35073026
Bit of restructuring!

Chris
Sub Email4Excel()
' Requires excel object library to be added to the outlook VBA references
Dim olApp As Object
Dim objNS As Object
Dim myfolder As Object
Dim mai As Object
Dim xlapp As Object
Dim xlwb As Object
Dim xlws As Object
Dim xlpath As String
Dim xlBook As String
Dim xlSheet As String
Dim maiInspector As Object
Dim xlIsOpen As Boolean
Dim acct As Object
 
    #If cbPC = True Then
        xlpath = "C:\Users\Chris\Experts Exchange"
        xlBook = "deleteme.xls"
        xlSheet = "Sheet1"
    #Else
        xlpath = "C:\"
        xlBook = "random.xls"
        xlSheet = "Sheet1"
    #End If
    
    On Error Resume Next
    Set olApp = CreateObject("Outlook.Application")
    Set acct = olApp.session.accounts.Item(getPST(olApp))
    Set objNS = acct.session
'    Set myfolder = objNS.PickFolder
    Set myfolder = objNS.session.GetDefaultFolder(6)
                   
    Set xlapp = GetObject(, "Excel.Application")
    xlIsOpen = (Not xlapp Is Nothing)
    If xlapp Is Nothing Then Set xlapp = CreateObject("Excel.application")
    ' fileExists modifies trims path and ensures a trailing slash
    If FileExists1(xlpath, xlBook) Then
        On Error Resume Next
        Set xlwb = xlapp.Workbooks(xlBook)
        On Error GoTo 0
        If xlwb Is Nothing Then Set xlwb = xlapp.Workbooks.Open(xlpath & xlBook)
        If xlws Is Nothing Then Set xlws = xlwb.Worksheets(xlSheet)
    Else
         Set xlwb = xlapp.Workbooks.Add
         xlwb.SaveAs Filename:=(xlpath & xlBook)
         If xlws Is Nothing Then Set xlws = xlwb.Worksheets(xlSheet)
    End If
    xlws.Cells.Clear
    xlws.Range("A1") = "Sender Email"
    xlws.Range("B1") = "Sender Name"
    For Each mai In myfolder.items
        If mai.Class = olmail Then
           On Error GoTo assumeEncrypted
               On Error GoTo inspectMai
               xlws.Range("A" & xlws.Rows.Count).End(xlUp).Offset(1, 0) = mai.SenderEmailAddress
               xlws.Range("B" & xlws.Rows.Count).End(xlUp).Offset(1, 0) = mai.SenderName
           On Error GoTo assumeEncrypted
        End If
        GoTo assumeEncrypted
inspectMai:
    Set maiInspector = mai.GetInspector
    maiInspector.Activate
    Stop
    If Not maiInspector Is Nothing Then maiInspector.Close (olDiscard)
    Err.Clear
assumeEncrypted:
    Next
    xlws.Columns("A:B").EntireColumn.AutoFit
    GoTo exiat
 
    
exiat:
    If Not xlapp Is Nothing Then
        xlapp.DisplayAlerts = False
        If Not xlwb Is Nothing Then xlwb.Save
        If Not xlwb Is Nothing And Not xlIsOpen Then xlwb.Close
        xlapp.DisplayAlerts = True
        Set xlapp = Nothing
    End If
Set objNS = Nothing
Set olApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Public Function FileExists1(ByRef strFolder, strFilename) As Boolean
    FileExists1 = False
    strFolder = Replace(strFolder, Chr(160), " ")
    strFolder = Trim(strFolder)
    If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
    If Len(Dir(strFolder & strFilename)) > 0 Then FileExists1 = True
End Function

Function getPST(olkapp As Object) As Integer
Dim olkAccount As Object
Dim intIndex As Integer
Dim chIndex As String
Dim strMessage As String

    getPST = 1
    For intIndex = 1 To olkapp.session.accounts.Count
        Set olkAccount = olkapp.session.accounts.Item(intIndex)
        strMessage = strMessage & intIndex & " = " & olkAccount.DisplayName & vbLf
    Next
    chIndex = InputBox("Select Account using the index number:" & vbCrLf & vbCrLf & strMessage, "Select Account")
    If IsNumeric(chIndex) Then
        If chIndex >= 1 And chIndex <= olkapp.session.accounts.Count Then
            getPST = chIndex
        End If
    End If

End Function

Open in new window

0
 
LVL 7

Author Comment

by:Brad Sims, CCNA
ID: 35073848
I uncommented this line ---

'    Set myfolder = objNS.PickFolder

---and it works perfectly!

You really are a Genius!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35073948
I thought you wante dthe inbox ... but I see another booboo!

Set myfolder = objNS.session.GetDefaultFolder(6)
should be
Set myfolder = objNS.GetDefaultFolder(6)

This should select the inbox without having to make the selection ... but either way, glad it helped.

BTW just looked at the referenced question ... two years ago and whilst some of my approaches have changed, (hence my latest error noted here) it still looks much the same as I code today.

Chris
0

Featured Post

On Demand Webinar: Networking for the Cloud Era

Ready to improve network connectivity? Watch this webinar to learn how SD-WANs and a one-click instant connect tool can boost provisions, deployment, and management of your cloud connection.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…
Suggested Courses

752 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question