Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Outlook VBA Code - Needs Modified

Posted on 2011-03-08
12
Medium Priority
?
534 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
Free Backup Tool for VMware and Hyper-V

Restore full virtual machine or individual guest files from 19 common file systems directly from the backup file. Schedule VM backups with PowerShell scripts. Set desired time, lean back and let the script to notify you via email upon completion.  

 
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

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

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

This article lists the top 5 free OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their exchange server is no longer available or some other critical issue with exchange server or impor…
Outlook for dependable use in a very small business   This article is about using the Outlook application (part of Microsoft Office) in a very small business, or for homeowners where dependability and reliability are critical requirements. This …
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…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

618 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