Solved

Outlook VBA Code - Needs Modified

Posted on 2011-03-08
12
519 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
  • 6
  • 6
12 Comments
 
LVL 7

Author Comment

by:Brad Sims
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
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
VMware Disaster Recovery and Data Protection

In this expert guide, you’ll learn about the components of a Modern Data Center. You will use cases for the value-added capabilities of Veeam®, including combining backup and replication for VMware disaster recovery and using replication for data center migration.

 
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
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
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
ID: 35072654
Guess that would help...sorry.

For Each mai In myfolder.Items
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 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
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

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Finding a closest match in Excel 7 47
Excel IF formula 3 20
Excel format formula for currency 15 23
vba autofilter in row 4 6 11
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

772 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