Solved

Outlook VBA Code - Needs Modified

Posted on 2011-03-08
12
514 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
 
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
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 
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

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Learn more about how the humble email signature can be used as more than just an electronic business card. When used correctly, a signature can easily be tailored for different purposes by different departments within an organization.
Outlook Free & Paid Tools
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
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.

743 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now