Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Having an Outlook 2003 SP3 macro run every day.

Posted on 2011-03-11
11
Medium Priority
?
656 Views
Last Modified: 2012-06-27
Hi.

I have a macro which examines a public folder (we use exchange) and, for each sub-folder, moves the mailitems in the sub-folder further down the tree based upon the date the item was received.

Running the macro every day, manually, and all is well.

The macro only needs to be run once a day as the mail items are reports which are generated daily for the previous day's work.

The macro is  
Sub SortRecharges()
    Dim _
        o_App As Outlook.Application, _
        o_RechargeFolder As Outlook.MAPIFolder, _
        o_ContractFolder As Outlook.MAPIFolder, _
        o_YearFolder As Outlook.MAPIFolder, _
        o_MonthFolder As Outlook.MAPIFolder, _
        o_DayFolder As Outlook.MAPIFolder, _
        o_Item As Outlook.MailItem
    Dim _
        b_YMDFolder As Boolean, _
        dt_Received As Date, _
        i_Item As Integer, _
        i_Items As Integer, _
        s_RechargeFolderID As String

    s_RechargeFolderID = "000000001A447390AA6611CD9BC800AA002FC45A030085FB38B65F840A438204B33E62CC2FC4000000169FB80000"

    Set o_App = CreateObject("Outlook.Application")
    Set o_RechargeFolder = o_App.GetNamespace("Mapi").GetFolderFromID(s_RechargeFolderID)

    ' Verify Recharge Folder.
    If o_RechargeFolder.Name <> "Recharge Reports" Then
        MsgBox _
            Prompt:="Folder is not the Recharge Reports folder." & Chr(13) & Chr(13) & "Selected folder is : " & o_RechargeFolder.Name, _
            Buttons:=vbExclamation + vbOKOnly, _
            Title:="ERROR : Invalid folder selected"
        Exit Sub
    End If

    ' Iterate the current contracts
    For Each o_ContractFolder In o_RechargeFolder.Folders
        ' We ignore "Retired"
        If "Retired" <> o_ContractFolder.Name Then

            ' Determine if we need to look at Year\Month\Day or Year only.
            If "ASDA" = o_ContractFolder.Name Or "Hartshorne" = o_ContractFolder.Name Or "Hill Hire" = o_ContractFolder.Name Then
                b_YMDFolder = True
            Else
                b_YMDFolder = False
            End If

            Debug.Print "Examining " & o_ContractFolder.Name

            ' Iterate the items.
            i_Items = o_ContractFolder.Items.Count
            i_Item = 0
            ' NOTE : Use a reverse for loop rather than for each as the pointer is updated to the next item immediately after the move and then Next skips an item.
            For i_Item = i_Items To 1 Step of - 1

                Set o_Item = o_ContractFolder.Items(i_Item)

                Debug.Print "Processing item #" & i_Item & " of " & i_Items & " reports : " & o_Item.Subject
                
                ' Mark as read
                If True = o_Item.UnRead Then
                    o_Item.UnRead = False
                End If

                ' File the reports generated today in yesterday's folder.
                dt_Received = o_Item.ReceivedTime - 1

                ' Find the appropriate destination file
                If b_YMDFolder = True Then
                    Set o_YearFolder = CheckFolder(o_ContractFolder, CStr(Year(dt_Received)))
                    Set o_MonthFolder = CheckFolder(o_YearFolder, Format(Month(dt_Received), "00"))
                    Set o_DayFolder = CheckFolder(o_MonthFolder, Format(Day(dt_Received), "00"))
                Else
                    Set o_DayFolder = CheckFolder(o_ContractFolder, CStr(Year(dt_Received)))
                End If

                o_Item.Move DestFldr:=o_DayFolder
            Next i_Item

        End If

    Next o_ContractFolder

End Sub

Function CheckFolder(o_Folder As Outlook.MAPIFolder, s_SubFolder As String)
    Dim o_SubFolder As Outlook.MAPIFolder

    Set CheckFolder = Nothing
    On Error Resume Next
    Set CheckFolder = o_Folder.Folders.Add(s_SubFolder)
    On Error GoTo 0

    If Not CheckFolder Is Nothing Then
    Else
        Set CheckFolder = o_Folder.Folders(s_SubFolder)
    End If
End Function

Open in new window


From what I've been reading, the way to get this macro to run daily is to create a task with a reminder and then use Private Sub Application_Reminder(ByVal Item As Object) to watch for that reminder and fire the macro.

Is this the only way? Is there a way to attach a macro to an event within Outlook's UI?

The macro is self-signed, so I don't get the popup/delay box about someone accessing the mail.

Regards,

Richard Quadling.
0
Comment
Question by:Richard Quadling
[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
  • 7
  • 4
11 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 2000 total points
ID: 35107713
Hi, Richard.

Yes, it's possible to fire the macro from another event.  For example you could run it when Outlook is first launched via the Application_Startup event.  That event fires each time Outlook is launched, so it could fire multiple times each day depending on how you use Outlook.  You could also set it to run each time Outlook checks for mail, but again that would mean running the macro more than once a day.  I can't think of any events that happen on a schedule and only occur once a day.

You could also modify the macro to run from outside of Outlook and use Windows Task Scheduler to run it.
0
 
LVL 40

Author Comment

by:Richard Quadling
ID: 35107918
I'm not a VBA person, (PHP is my AofE). How do I convert my macro to something that can run outside of Outlook?

More points for this additional request.
0
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 2000 total points
ID: 35107999
I've edited your code and made what I believe are all the changes required for this to run from outside of Outlook.  I can't test it though in my environment.

To use this

1.  Open Notepad
2.  Copy and paste the code into Notepad
3.  Save to a file with an extension of .vbs

Double-click the file to run it.  If it works, then you can use Windows Scheduler to run it.  Outlook needs to be open when the script is run.  If it's not, then we'll need to add a couple of additional lines of code to log into Outlook.
SortRecharges
WScript.Quit

Sub SortRecharges()
    Dim _
        o_App, _
        o_RechargeFolder, _
        o_ContractFolder, _
        o_YearFolder, _
        o_MonthFolder, _
        o_DayFolder, _
        o_Item
    Dim _
        b_YMDFolder, _
        dt_Received, _
        i_Item, _
        i_Items, _
        s_RechargeFolderID

    s_RechargeFolderID = "000000001A447390AA6611CD9BC800AA002FC45A030085FB38B65F840A438204B33E62CC2FC4000000169FB80000"

    Set o_App = CreateObject("Outlook.Application")
    Set o_RechargeFolder = o_App.GetNamespace("Mapi").GetFolderFromID(s_RechargeFolderID)

    ' Verify Recharge Folder.
    If o_RechargeFolder.Name <> "Recharge Reports" Then
        MsgBox _
            Prompt:="Folder is not the Recharge Reports folder." & Chr(13) & Chr(13) & "Selected folder is : " & o_RechargeFolder.Name, _
            Buttons:=vbExclamation + vbOKOnly, _
            Title:="ERROR : Invalid folder selected"
        Exit Sub
    End If

    ' Iterate the current contracts
    For Each o_ContractFolder In o_RechargeFolder.Folders
        ' We ignore "Retired"
        If "Retired" <> o_ContractFolder.Name Then

            ' Determine if we need to look at Year\Month\Day or Year only.
            If "ASDA" = o_ContractFolder.Name Or "Hartshorne" = o_ContractFolder.Name Or "Hill Hire" = o_ContractFolder.Name Then
                b_YMDFolder = True
            Else
                b_YMDFolder = False
            End If

            Debug.Print "Examining " & o_ContractFolder.Name

            ' Iterate the items.
            i_Items = o_ContractFolder.Items.Count
            i_Item = 0
            ' NOTE : Use a reverse for loop rather than for each as the pointer is updated to the next item immediately after the move and then Next skips an item.
            For i_Item = i_Items To 1 Step of - 1

                Set o_Item = o_ContractFolder.Items(i_Item)

                Debug.Print "Processing item #" & i_Item & " of " & i_Items & " reports : " & o_Item.Subject
                
                ' Mark as read
                If True = o_Item.UnRead Then
                    o_Item.UnRead = False
                End If

                ' File the reports generated today in yesterday's folder.
                dt_Received = o_Item.ReceivedTime - 1

                ' Find the appropriate destination file
                If b_YMDFolder = True Then
                    Set o_YearFolder = CheckFolder(o_ContractFolder, CStr(Year(dt_Received)))
                    Set o_MonthFolder = CheckFolder(o_YearFolder, Format(Month(dt_Received), "00"))
                    Set o_DayFolder = CheckFolder(o_MonthFolder, Format(Day(dt_Received), "00"))
                Else
                    Set o_DayFolder = CheckFolder(o_ContractFolder, CStr(Year(dt_Received)))
                End If

                o_Item.Move DestFldr:=o_DayFolder
            Next i_Item

        End If

    Next o_ContractFolder

End Sub

Function CheckFolder(o_Folder, s_SubFolder)
    Dim o_SubFolder

    Set CheckFolder = Nothing
    On Error Resume Next
    Set CheckFolder = o_Folder.Folders.Add(s_SubFolder)
    On Error GoTo 0

    If Not CheckFolder Is Nothing Then
    Else
        Set CheckFolder = o_Folder.Folders(s_SubFolder)
    End If
End Function

Open in new window

0
Office 365 Training for Admins - 7 Day Trial

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

 
LVL 40

Author Comment

by:Richard Quadling
ID: 35109004
I'm getting compilation errors.

Line 28, Char 20, Expected statement.

Turning the msgbox call into a single line, changes the error to ...

Line 27, Char 23, Expected statement.

Seems that the parm:=value format is an issue.

Changing it to a normal function call with a result assignment ...

        m_Failure = MsgBox("Folder is not the Recharge Reports folder." & Chr(13) & Chr(13) & "Selected folder is : " & o_RechargeFolder.Name, vbExclamation + vbOKOnly, "ERROR : Invalid folder selected")

Having passed that, I get ...

Line 72, Char 38, Expected statement.

Another line of code with named parameters. Changing it to any of the following does not work ...

o_Item.Move(o_DayFolder)
o_Item.Move o_DayFolder
Set x_Unknown = o_Item.Move(o_DayFolder)
Set x_Unknown = o_Item.Move o_DayFolder

Stuck with this one.
0
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 2000 total points
ID: 35109525
This is the correct syntax

o_Item.Move o_DayFolder

What happens when you change the line to this?  An error or it just doesn't work?  
0
 
LVL 40

Author Comment

by:Richard Quadling
ID: 35110126
Line 74 Char 18 Expected end of statement



                o_Item.Move o_DayFolder

>>Line 74            Next i_Item

        End If

Char 18 is at the i of i_Item.

Very odd.

Full source  
SortRecharges
WScript.Quit

Sub SortRecharges()
    Dim _
        o_App, _
        o_RechargeFolder, _
        o_ContractFolder, _
        o_YearFolder, _
        o_MonthFolder, _
        o_DayFolder, _
        o_Item
    Dim _
        b_YMDFolder, _
        dt_Received, _
        i_Item, _
        i_Items, _
        s_RechargeFolderID

    s_RechargeFolderID = "000000001A447390AA6611CD9BC800AA002FC45A030085FB38B65F840A438204B33E62CC2FC4000000169FB80000"

    Set o_App = CreateObject("Outlook.Application")
    Set o_RechargeFolder = o_App.GetNamespace("Mapi").GetFolderFromID(s_RechargeFolderID)

    ' Verify Recharge Folder.
    If o_RechargeFolder.Name <> "Recharge Reports" Then
        m_Failure = MsgBox("Folder is not the Recharge Reports folder." & Chr(13) & Chr(13) & "Selected folder is : " & o_RechargeFolder.Name, vbExclamation + vbOKOnly, "ERROR : Invalid folder selected")
        Exit Sub
    End If

    ' Iterate the current contracts
    For Each o_ContractFolder In o_RechargeFolder.Folders
        ' We ignore "Retired"
        If "Retired" <> o_ContractFolder.Name Then

            ' Determine if we need to look at Year\Month\Day or Year only.
            If "ASDA" = o_ContractFolder.Name Or "Hartshorne" = o_ContractFolder.Name Or "Hill Hire" = o_ContractFolder.Name Then
                b_YMDFolder = True
            Else
                b_YMDFolder = False
            End If

            Debug.Print "Examining " & o_ContractFolder.Name

            ' Iterate the items.
            i_Items = o_ContractFolder.Items.Count
            i_Item = 0
            ' NOTE : Use a reverse for loop rather than for each as the pointer is updated to the next item immediately after the move and then Next skips an item.
            For i_Item = i_Items To 1 Step of - 1

                Set o_Item = o_ContractFolder.Items(i_Item)

                Debug.Print "Processing item #" & i_Item & " of " & i_Items & " reports : " & o_Item.Subject

                ' Mark as read
                If True = o_Item.UnRead Then
                    o_Item.UnRead = False
                End If

                ' File the reports generated today in yesterday's folder.
                dt_Received = o_Item.ReceivedTime - 1

                ' Find the appropriate destination file
                If b_YMDFolder = True Then
                    Set o_YearFolder = CheckFolder(o_ContractFolder, CStr(Year(dt_Received)))
                    Set o_MonthFolder = CheckFolder(o_YearFolder, Format(Month(dt_Received), "00"))
                    Set o_DayFolder = CheckFolder(o_MonthFolder, Format(Day(dt_Received), "00"))
                Else
                    Set o_DayFolder = CheckFolder(o_ContractFolder, CStr(Year(dt_Received)))
                End If

                o_Item.Move o_DayFolder

            Next i_Item

        End If

    Next o_ContractFolder

End Sub

Function CheckFolder(o_Folder, s_SubFolder)
    Dim o_SubFolder

    Set CheckFolder = Nothing
    On Error Resume Next
    Set CheckFolder = o_Folder.Folders.Add(s_SubFolder)
    On Error GoTo 0

    If Not CheckFolder Is Nothing Then
    Else
        Set CheckFolder = o_Folder.Folders(s_SubFolder)
    End If
End Function

Open in new window

0
 
LVL 40

Author Comment

by:Richard Quadling
ID: 35110155
Aha!

Seems VBA vs VBS difference.

VBA

for i = 1 to 10
 ...
next i


VBS

for i = 1 to 10
 ...
next


0
 
LVL 40

Author Comment

by:Richard Quadling
ID: 35110189
No debug object. debug.prints commented out.

Now ...

Line 66, Char 21, Type mismatch: 'Format'

And http://bytes.com/topic/asp-classic/answers/54192-type-mismatch-using-format is my reason.

Who'd have thought the MS would have gone to such trouble of having so many languages all called "Visual Basic" and have none of them compatible with each other!

0
 
LVL 40

Author Comment

by:Richard Quadling
ID: 35110268
Wahay. No errors. Now just need to wait for some mail to arrive.

Thanks for the help.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35110742
Not sure how much I helped, but you're welcome.  VBA is almost identical to VB6.  VBScript differs in that it doesn't support typed variable declarations and a few of the commands available in VBA/VB6 aren't available in VBScript (e.g. Format).  If you find that you need to do much work with VBScript, then I strongly recommend a tool called VBSEdit.  Its a VBScript code editor with integrated debugger that makes working with VBS a lot easier.
0
 
LVL 40

Author Comment

by:Richard Quadling
ID: 35111027
You helped by being on the end of the virtual line.

0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

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…
One-stop solution for Exchange Administrators to address all MS Exchange Server issues, which is known by the name of Stellar Exchange Toolkit.
The basic steps you have just learned will be implemented in this video. The basic steps are shown to configure an Exchange DAG in a live working Exchange Server Environment and manage the same (Exchange Server 2010 Software is used in a Windows Ser…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …
Suggested Courses

688 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