Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Having an Outlook 2003 SP3 macro run every day.

Posted on 2011-03-11
11
Medium Priority
?
660 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
  • 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
Simplify Active Directory Administration

Administration of Active Directory does not have to be hard.  Too often what should be a simple task is made more difficult than it needs to be.The solution?  Hyena from SystemTools Software.  With ease-of-use as well as powerful importing and bulk updating capabilities.

 
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

New feature and membership benefit!

New feature! Upgrade and increase expert visibility of your issues with Priority Questions.

Question has a verified solution.

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

Steps to fix “Unable to mount database. (hr=0x80004005, ec=1108)”.
In this post, I will showcase the steps for how to create groups in Office 365. Office 365 groups allow for ease of flexibility and collaboration between staff members.
This video shows how to quickly and easily add an email signature for all users on Exchange 2016. The resulting signature is applied on a server level by Exchange Online. The email signature template has been downloaded from: www.mail-signatures…
Exchange organizations may use the Journaling Agent of the Transport Service to archive messages going through Exchange. However, if the Transport Service is integrated with some email content management application (such as an antispam), the admini…
Suggested Courses

971 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