Solved

Having an Outlook 2003 SP3 macro run every day.

Posted on 2011-03-11
11
625 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:RQuadling
  • 7
  • 4
11 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 500 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:RQuadling
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 500 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
 
LVL 40

Author Comment

by:RQuadling
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 500 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
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 40

Author Comment

by:RQuadling
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:RQuadling
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:RQuadling
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:RQuadling
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:RQuadling
ID: 35111027
You helped by being on the end of the virtual line.

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

Find out how to use Active Directory data for email signature management in Microsoft Exchange and Office 365.
Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
To show how to generate a certificate request in Exchange 2013. We show this process by using the Exchange Admin Center. Log into Exchange Admin Center.:  First we need to log into the Exchange Admin Center. Navigate to the Servers >> Certificates…
how to add IIS SMTP to handle application/Scanner relays into office 365.

760 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

17 Experts available now in Live!

Get 1:1 Help Now