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

x
?
Solved

Outlook Macro

Posted on 2013-11-07
4
Medium Priority
?
359 Views
Last Modified: 2013-11-07
Hi Guys

Can anyone please help to use the below macro for the shared Inbox. As presently I can only run and get the data for the personal inbox


Sub Q28274550_1()
Dim acct As Account
Dim fldr As MAPIFolder
Dim arr As Variant
Dim intArraySize As Integer
Dim elem As Integer
Dim xlapp As Object
Dim xlWB As Object
Dim xlSh As Object

    intArraySize = 0
    ReDim arr(2, 0)
    For Each acct In Application.Session.Accounts
        ReDim Preserve arr(2, intArraySize)
        Set fldr = Application.Session.GetFolderFromID(acct.DeliveryStore.StoreID).Folders("Inbox")
        Q28274550_1a fldr, intArraySize, arr
    Next
    Set xlapp = CreateObject("excel.application")
    xlapp.Visible = False
    xlapp.screenupdating = False
    xlapp.enableevents = False
    Set xlWB = xlapp.workbooks.Add
    Set xlSh = xlWB.sheets(1)
    For elem = 0 To UBound(arr, 2)
'        Debug.Print arr(0, elem) & "<>" & arr(1, elem) & "<>" & arr(2, elem)
        xlSh.cells(elem + 1, 1) = arr(0, elem)
        xlSh.cells(elem + 1, 2) = arr(1, elem)
        xlSh.cells(elem + 1, 3) = arr(2, elem)
    Next
    
    With xlSh.Sort
        .SortFields.Add Key:=xlSh.Range("B1:B100") _
            , SortOn:=0, Order:=1, DataOption:=0
        .SortFields.Add Key:=xlSh.Range("A1") _
            , SortOn:=0, Order:=1, DataOption:=0
        .SetRange xlSh.cells
        .Header = 2
        .MatchCase = False
        .Orientation = 1
        .SortMethod = 1
        .Apply
    End With
    
    
    xlSh.Range("1:3").Columns.autofit
    xlapp.screenupdating = True
    xlapp.enableevents = True
    xlapp.Visible = True

End Sub

Function Q28274550_1a(fldr As MAPIFolder, intArraySize As Integer, arr As Variant)
Dim subFolder As MAPIFolder
Dim strFilter As String
Dim lngItemCount As Long
Dim strStarttime As String
Dim strFinishTime As String
Dim folderItems As Object
Dim strStart As String
Dim varStart As Variant
Dim strEnd As String
Dim varEnd As Variant
Dim varPeriod As Variant
Dim strIncrement As Integer
Dim varIncrement As Variant

    strStart = "08:00:00"
    strEnd = "17:00:00"
    strIncrement = 30
    varStart = TimeValue(strStart)
    varEnd = TimeValue(strEnd)
    varIncrement = TimeValue("00:" & strIncrement & ":00")
    For varPeriod = varStart To varEnd Step varIncrement
        strStarttime = Format(Date + varPeriod, "ddddd h:nn AMPM")
        strFinishTime = Format(DateAdd("n", strIncrement, Date + varPeriod), "ddddd h:nn AMPM")
        strFilter = "[ReceivedTime] >= '" & strStarttime & "'" & " and " & "[ReceivedTime] < '" & strFinishTime & "'"
        Set folderItems = fldr.Items.Restrict(strFilter)
        lngItemCount = folderItems.Count
        ReDim Preserve arr(2, intArraySize)
        arr(0, intArraySize) = fldr.FolderPath
        arr(1, intArraySize) = Format(strStarttime, "hh:mm") & " - " & Format(strFinishTime, "hh:mm")
        arr(2, intArraySize) = lngItemCount
        intArraySize = intArraySize + 1
    Next
    
'    Debug.Print fldr.FolderPath & " <> " & lngItemCount
    For Each subFolder In fldr.Folders
        Q28274550_1a subFolder, intArraySize, arr
    Next

End Function 

Open in new window

0
Comment
Question by:surah79
[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
  • 2
  • 2
4 Comments
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 2000 total points
ID: 39631977
I cannot test so I leave it to you to test ... or someone else to upload a valid solution but try the following:

Sub Q28274550_2()
Dim acct As Account
Dim fldr As MAPIFolder
Dim arr As Variant
Dim intArraySize As Integer
Dim elem As Integer
Dim xlapp As Object
Dim xlWB As Object
Dim xlSh As Object
Dim recip As Recipient

    intArraySize = 0
    ReDim arr(2, 0)
    For Each acct In Application.Session.Accounts
        ReDim Preserve arr(2, intArraySize)
        Set fldr = Application.Session.GetFolderFromID(acct.DeliveryStore.StoreID).Folders("Inbox")
        Q28274550_1a fldr, intArraySize, arr
    Next
    ReDim Preserve arr(2, intArraySize)
    Set recip = Application.Session.CreateRecipient("mail@domain.com")
    Set fldr = Application.Session.GetSharedDefaultFolder(recip, olFolderInbox)
    Q28274550_1a fldr, intArraySize, arr
    
    Set xlapp = CreateObject("excel.application")
    xlapp.Visible = False
    xlapp.screenupdating = False
    xlapp.enableevents = False
    Set xlWB = xlapp.workbooks.Add
    Set xlSh = xlWB.sheets(1)
    For elem = 0 To UBound(arr, 2)
'        Debug.Print arr(0, elem) & "<>" & arr(1, elem) & "<>" & arr(2, elem)
        xlSh.cells(elem + 1, 1) = arr(0, elem)
        xlSh.cells(elem + 1, 2) = arr(1, elem)
        xlSh.cells(elem + 1, 3) = arr(2, elem)
    Next
    
    With xlSh.Sort
        .SortFields.Add Key:=xlSh.Range("B1:B100") _
            , SortOn:=0, Order:=1, DataOption:=0
        .SortFields.Add Key:=xlSh.Range("A1") _
            , SortOn:=0, Order:=1, DataOption:=0
        .SetRange xlSh.cells
        .Header = 2
        .MatchCase = False
        .Orientation = 1
        .SortMethod = 1
        .Apply
    End With
    
    
    xlSh.Range("1:3").Columns.autofit
    xlapp.screenupdating = True
    xlapp.enableevents = True
    xlapp.Visible = True

End Sub

Function Q28274550_1a(fldr As MAPIFolder, intArraySize As Integer, arr As Variant)
Dim subFolder As MAPIFolder
Dim strFilter As String
Dim lngItemCount As Long
Dim strStarttime As String
Dim strFinishTime As String
Dim folderItems As Object
Dim strStart As String
Dim varStart As Variant
Dim strEnd As String
Dim varEnd As Variant
Dim varPeriod As Variant
Dim strIncrement As Integer
Dim varIncrement As Variant

    strStart = "08:00:00"
    strEnd = "17:00:00"
    strIncrement = 90
    varStart = TimeValue(strStart)
    varEnd = TimeValue(strEnd)
'    varIncrement = TimeValue("00:" & strIncrement & ":00")
    varIncrement = Format(DateAdd("n", strIncrement, (Date + TimeValue("00:00:00"))), "hh:mm:ss")
    For varPeriod = varStart To varEnd Step varIncrement
        strStarttime = Format(Date + varPeriod, "ddddd h:nn AMPM")
        strFinishTime = Format(DateAdd("n", strIncrement, Date + varPeriod), "ddddd h:nn AMPM")
        strFilter = "[ReceivedTime] >= '" & strStarttime & "'" & " and " & "[ReceivedTime] < '" & strFinishTime & "'"
        Set folderItems = fldr.Items.Restrict(strFilter)
        lngItemCount = folderItems.Count
        ReDim Preserve arr(2, intArraySize)
        arr(0, intArraySize) = fldr.FolderPath
        arr(1, intArraySize) = Format(strStarttime, "hh:mm") & " - " & Format(strFinishTime, "hh:mm")
        arr(2, intArraySize) = lngItemCount
        intArraySize = intArraySize + 1
    Next
    
'    Debug.Print fldr.FolderPath & " <> " & lngItemCount
    For Each subFolder In fldr.Folders
        Q28274550_1a subFolder, intArraySize, arr
    Next

End Function

Open in new window


Modify the string mail@domain.com at line 20 to reflect the users email address and with a bit of luck it'll work the same as before but with the extra pst.

Chris
0
 

Author Closing Comment

by:surah79
ID: 39632216
Awesome it works like a charm
0
 

Author Comment

by:surah79
ID: 39632226
sorry Chris last bit , can we also able to include the subfolder of the Shared Inbox,can I ask this as another new question on this.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 39632741
Sorry yu caught me overnight … the script should already return the subfolders of the inbox as it uses exactly the same recursion as the other solution.

Can you perhaps provide more details on the difference?

Chris
0

Featured Post

Independent Software Vendors: 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!

Question has a verified solution.

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

When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
This article will help to fix the below errors for MS Exchange Server 2013 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This is Part 3 in a 3-part series on Experts Exchange to discuss error handling in VBA code written for Excel. Part 1 of this series discussed basic error handling code using VBA. http://www.experts-exchange.com/videos/1478/Excel-Error-Handlin…

604 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