RE: Automated macro shut down

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

By shutdown do you mean that all of the objects declared in your code becomes
dereferenced?

Regardless, a COM Add-In is a far more reliable method for running code than
VBA macros.

--
Eric Legault - Outlook MVP, MCDBA, MCTS (SharePoint programming, etc.)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/


"Hilfy" wrote:

Outlook 2003, Win XP sp2, VBA.

Hi there,
I have an Outlook macro that is automated using the AddItem event.
It's pretty simple, when email hits a certain folder, it saves all
attachments and makes a calendar appointment on the email received
date and attaches the saved email attachments to the appointment, sets
categories and saves some info to a text field. It usually runs just
fine and we don't seem to hit the 16 item limit on the AddItem event.

The problem is that every Thursday the macro shuts down without any
error messages; it's set up to show error messages. Now, I know there
could be a million things causing this and I don't expect someone to
be able to give me an exact answer for my problem. What I'm looking
for here is some help identifying Outlook or other processes that
would shut down macros such as mine. I've already determined that the
problem is not the network connection to the folder where the
attachments are saved. This was resolved by changing the pathway to a
local pathway - still got the shutdown. The other thing that happens
regularly here is they run Dagent alot- would that do it? I'm
fishing... Hilfy

Here's the code if anyone's interested:
Option Explicit
Option Compare Text

Dim WithEvents TargetFolderItems As Items 'Event handler for Lab
Reports folder
Dim nsDennis As NameSpace 'Namespace object
Dim olCalendar As Outlook.MAPIFolder 'calendar object
Dim i As Integer 'counter to help make unique subjects

Public Sub Application_Startup()
Set nsDennis = Application.GetNamespace("MAPI") 'set Namespace object
Set TargetFolderItems = nsDennis.Folders("DWR PIM").Folders("Lab
Reports").Items 'set Target folders object
Set TargetFolderItems2 = nsDennis.Folders("DWR PIM").Folders("Pending
Lab Cal").Items 'set Target folders 2 object
End Sub
Public Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
Dim olApptLabRes As Outlook.AppointmentItem 'Lab Results Appointment
Object
Dim strSubject As String 'Holds subject of email
Dim strLReport As String 'Lab report string with
which to parse subject
Dim objRecip As Outlook.Recipient 'Outlook recipient object
Dim strMailbox As String 'holds name of mailbox
whose calendar you want to use
Dim objCalFolder As Outlook.MAPIFolder 'Calendar object
Dim strDateReceived As String 'Hold received Date/Time
from email
Dim OlApptFind As Outlook.AppointmentItem 'Appointment item object
for subject comparision
Dim lDateLength As Long 'find Date insertion in
Date received string
Dim strDateString As String 'string for getting date
Dim astrTaskNum() As String 'Array for splitting
subject to get Tasknumber
Dim strTaskNum As String 'holds task number
Dim y As Integer 'counter to loop through
astrTaskNum array
Dim strID As String 'store item ID
Dim vStoreID As Variant 'store parent ID

strMailbox = "CHS Environmental Lab" 'Name of mailbox
whose calendar you want to use
Set objRecip = nsDennis.CreateRecipient(strMailbox) 'Set recipient
object to above string
strLReport = "*lab report*" 'Look for this
string in subject
Set objCalFolder = nsDennis.GetSharedDefaultFolder(objRecip,
olFolderCalendar) 'Set Calendar object

If TypeName(Item) = "MailItem" Then 'is item email?
strSubject = Item.Subject 'pick up email subject
Set OlApptFind = objCalFolder.Items.Find("[Subject] = " & Chr(34) &
strSubject & Chr(34)) 'Filter appointments by subject- looking for the
current subject
If OlApptFind Is Nothing Then 'If appointment has
not already been made, make appointment
strDateReceived = Item.ReceivedTime 'pick up email received time
lDateLength = InStrRev(strDateReceived, "/", , vbTextCompare)
'find last "/" in date received string
lDateLength = lDateLength + 4 'add 4 to make sure you capture year
strDateString = Left(strDateReceived, lDateLength) 'get date from
date/time received string
If Not objCalFolder Is Nothing Then 'make sure calendar
object is set
If strSubject Like strLReport Then 'Make sure subject
says Lab report
Set olApptLabRes =
objCalFolder.Items.Add(olAppointmentItem) 'make new appointment in
calendar for Lab Result
'fill out details about appointment
With olApptLabRes
.Subject = Item.Subject
.AllDayEvent = True
.Body = "Received by CHS on: " & strDateString
.Start = strDateString
.ReminderSet = False
.BusyStatus = olFree
.Categories = "Report"
End With
Call CopyAttachments(Item, olApptLabRes) 'copy
attachments to appointment
olApptLabRes.Close olSave
Else
End If
Else
End If
Else
End If
Else
Item.Delete
End If

astrTaskNum = Split(Item.Subject, , , vbBinaryCompare) 'split subject
into string array
For y = 0 To UBound(astrTaskNum) Step 1 'loop
through items in array
If InStr(1, astrTaskNum(y), "T200", vbTextCompare) <> 0 Then
'looking for task number
strTaskNum = astrTaskNum(y)
'assign task number to string variable
Set OlApptFind = objCalFolder.Items.Find("[BillingInformation] = "
& Chr(34) & strTaskNum & Chr(34)) 'Filter appointments by task number
If Not OlApptFind Is Nothing Then 'if there are no
matches, skip process
With OlApptFind
.BillingInformation = strDateString 'Set Billing
information field to received date for lab report
End With
OlApptFind.Close olSave 'save and close
appointment
Else
End If
Else
End If
Next y
Item.Delete

'Clear all objects set in the sub
Set olApptLabRes = Nothing
Set objCalFolder = Nothing
Set objRecip = Nothing
Set OlApptFind = Nothing
Set Item = Nothing
End Sub

Public Sub Application_Quit()
'Release major objects
Set TargetFolderItems = Nothing
Set TargetFolderItems2 = Nothing
Set nsDennis = Nothing
End Sub

Sub CopyAttachments(objSourceItem, objTargetItem)
Dim strPath As String 'holds pathway to folder for saving attachments
Dim objAtt As Outlook.Attachment 'attachment object
Dim strFile As String 'holds path/file name for creating file
Dim strFileName As String 'holds attachment file name
Dim strNewFileName As String 'holds new file name after date has been
added
Dim lStringLength As Long 'holds length of attachment file name
Dim strDateReceived2 As String 'holds date email with attachments
received
Dim lDateLength As Long 'holds length of date

For Each objAtt In objSourceItem.Attachments 'perform for all
attachments
strFileName = objAtt.FileName
strDateReceived2 = objSourceItem.ReceivedTime
lDateLength = InStrRev(strDateReceived2, "/", , vbTextCompare) 'Just
want the date, not the time
lDateLength = lDateLength + 4 'want entire date
strDateReceived2 = Left(strDateReceived2, lDateLength) 'get date from
string
strDateReceived2 = Replace(strDateReceived2, "/", "_") 'Replace bad
characters with good characters
lStringLength = InStr(1, strFileName, ".") 'get length of file name at
the "."
lStringLength = lStringLength - 1
strPath = "C:\Temp"
strNewFileName = Left(strFileName, lStringLength) & " " &
strDateReceived2 & Right(strFileName, 4) 'New file name is old file
name with Date inserted at the end
strFile = strPath & strNewFileName 'combine path and new file name
If Dir(strFile) <> "" Then 'check if file exists
i = i + 1 'counter for adding unique number to file name
strNewFileName = Left(strFileName, lStringLength) & i & " " &
strDateReceived2 & Right(strFileName, 4) 'New file name is old file
name with Date inserted at the end
strFile = strPath & strNewFileName 'combine path and new file name
objAtt.SaveAsFile strFile 'make new file
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName 'Add
attachment to new appointment

Else
objAtt.SaveAsFile strFile 'make new file
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName 'Add
attachment to new appointment
End If

Next
If i = 500 Then
i = 0 'don't let counter get too high
Else
End If
End Sub


.

Relevant Pages

  • Re: Automated macro shut down
    ... Try Picture Attachments Wizard for Outlook:http://www.collaborativeinnovations.ca ... date and attaches the saved email attachments to the appointment, ... Dim i As Integer 'counter to help make unique subjects ... Date received string ...
    (microsoft.public.office.developer.outlook.vba)
  • Automated macro shut down
    ... date and attaches the saved email attachments to the appointment, ... Dim WithEvents TargetFolderItems As Items 'Event handler for Lab ... Date received string ...
    (microsoft.public.office.developer.outlook.vba)
  • Re: Automated macro shut down
    ... Try Picture Attachments Wizard for Outlook:http://www.collaborativeinnovations.ca ... date and attaches the saved email attachments to the appointment, ... Dim i As Integer 'counter to help make unique subjects ... Date received string ...
    (microsoft.public.office.developer.outlook.vba)
  • Re: How do I automate Outlook to send an e-mail using VBA? ... CDO
    ... MVP Access ... Dim iConf As Object ... , pEmailAddress As String _ ... I'm trying to send a mail through MSAccess, I have no problem with that, but I can't send any attachments, because I'm using the "SendObject" way. ...
    (microsoft.public.access.modulesdaovba)
  • Re: Macro to open Access from Appointment form?
    ... Store the string as a Public variable declared in the ThisOutlookSessionModule. ... What is the best way to store strMdb so it will be globally available within Outlook? ... Dim acapp As Access.Application ... strAssigned = "This appointment is currently assigned to Entity ID ...
    (microsoft.public.outlook.program_forms)