Request Addition to Code- convertMail to AccountAppt (from www.Slipstick)

[TAVatPCU]

Hi, I am using the below code which converts a messge to an appointment on another mailbox's calendar that I have complete control to. It's great.

In some cases I would want to have a different Start and End dates so I guess a new 'sub' could be created, if this makes sense. To enhance this process I would appreicate some help to update the Start and End times.

I added in .display and update from it. But doing so saves the changes to my default calendar and not the other calendar. If I manually do a 'save as' to the other calendar I end up with two appts. on the other calendar (one for the ReceivedTime and one for the updated time ) . What code can be added to eliminate the original appt and keep only the updated one. Or is there a better way?

Thanks very much in advance.

----------------------------------------------------------------Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem

Set objAppt = Application.CreateItem(olAppointmentItem)
Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")

For Each objMail In Application.ActiveExplorer.Selection

objAppt.Subject = objMail.Subject


'sets it for recd. time AND not tomorrow at 9 AM per sample
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
objAppt.Move CalFolder
objAppt.Display

Next
Set objAppt = Nothing
Set objMail = Nothing

'MsgBox ("added to Calendar-Systems Schedules")

End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function

End Function

 

[Diane Poremsky]

If you want to display it, save it to the new calendar first. I think i have a tweaked macro that does that - I'll have to look.

If you want a default future time in the appoint you'd do something like this:

objAppt.Start = objMail.ReceivedTime + 3

 

[Diane Poremsky]

Found it -

Create it like you do now and save

With objAppt
.Subject = "Copied: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.Save

End With

Move it using this method:

Set moveCal= objAppt.Move(CalFolder)

Then display:

moveCal.display

Don't forget to Dim moveCal at the beginning of the macro.

Dim moveCal as AppointmentItem

 

[TAVatPCU]

Thanks very much. Is this what you mean? I am getting a run time error 424

---------------------------------------'sets it for recd. time AND not tomorrow as 9 AM per sample
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
objAppt.Move CalFolder
objAppt.Display
objAppt.Subject = "Copied: " & Item.Subject
objAppt.Start = Item.Start
objAppt.Duration = Item.Duration
objAppt.Location = Item.Location
objAppt.Body = Item.Body
objAppt.Save

'Move it using this method:

Set moveCal = objAppt.Move(CalFolder)

'Then display:

moveCal.Display
Next
Set objAppt = Nothing
Set objMail = Nothing

'MsgBox ("added to Calendar-Systems Schedules")

End Sub

----------------------I get a " Run-Time error '424': Object required. "

It occurs after I put in this:

'Move it using this method:

Set moveCal = objAppt.Move(CalFolder)

'Then display:

moveCal.Display

 

[Diane Poremsky]

I'm assuming you are still using this part -

Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem
Set objAppt = Application.CreateItem(olAppointmentItem)
Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")
For Each objMail In Application.ActiveExplorer.Selection

Did you add this line -

Dim moveCal as AppointmentItem

also - you don't need the first move - actually, it looks like the error is because outlook doesn't know what Item you are copying from. you don't need those - I usedi t to show you where to put the move command. Sorry.

'sets it for recd. time AND not tomorrow as 9 AM per sample
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
== > objAppt.Move CalFolder
objAppt.Display
objAppt.Subject = "Copied: " & Item.Subject
==> objAppt.Start = Item.Start
==> objAppt.Duration = Item.Duration
==> objAppt.Location = Item.Location

==> objAppt.Body = Item.Body
objAppt.Save

Try this

Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem
Dim moveCal As AppointmentItem
Set objAppt = Application.CreateItem(olAppointmentItem) 
 
Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")
For Each objMail In Application.ActiveExplorer.Selection 
 
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
objAppt.Subject = "Copied: " & objMail.Subject 
 
objAppt.Start = objMail.ReceivedTime + 3
objAppt.Save
'Move it using this method:
Set moveCal = objAppt.Move(CalFolder)
'Then display:
moveCal.Display
Next
Set objAppt = Nothing
Set objMail = Nothing
'MsgBox ("added to Calendar-Systems Schedules")
End Sub

 

[TAVatPCU]

Yeah it is working. Thanks very much. I tweaked it a bit by using just ' objAppt.Start = objMail.ReceivedTime ' (no + 3) as 50% of the time it will be run at current date & time or another date & time.

Another tweak I figured out thanks to you was ' objAppt.Location = "Copied: " & objMail.Subject ' and 'objAppt.Subject = "'' " ' This gives me a blank subject field to type into or copy and paste text.

One last question if I may. If in the body there will always be text of ' Subject:' something or other' could the text after the ' : ' be copied and pasted to the subject field?

Thanks again.

 

[Diane Poremsky]

Re: the Subject question - yes you can do it, but isn't that the same subject as in the email?

 

[TAVatPCU]

Ah, if it could only be...the message comes from a ticketing system with a ticket number in the subject line. It 'forwards' the original message it gets to the mailbox I am monitoring. The subject:xxxxx is thus moved into the body. I would like the " xxxxx " put into the appointment subject field.

Thanks again.

 

[Diane Poremsky]

That's do able. See http://www.slipstick.com/developer/regex-parse-message-text/ for the code sample.

you'll need to change this line:
.Pattern = "Carrier Tracking ID\s*[:]+\s*(\w*)\s*"

to match your pattern - Subject[:](\w*)\s*\n might work - but it might need to be tweaked.

Change omail to objmail and remove dim and set omail lines.

 

[TAVatPCU]

Per the link provided I checked Microsoft VBScript Regular Expressions 5.5 library in Tools, References.

Do I make the Module1 or insert the code into ThisOutlookSession?

What does ' \n ' do?

Here are the code adjustments I believe you indicated to make. Is this correct as no text is being entered into the objAppt.Subject? I attached an image as well. Thanks very much.

==================================================================

Sub GetValueUsingRegEx()

' Set reference to VB Script library

' Microsoft VBScript Regular Expressions 5.5

Dim Reg1 As RegExp

Dim M1 As MatchCollection

Dim M As Match

Set Reg1 = New RegExp

' \s* = invisible spaces

' \d* = match digits

' \w* = match alphanumeric

With Reg1

> Pattern = "Subject[:](\w*)\s*\n"

> Global = True

End With

If Reg1.test(objMail.Body) Then

Set M1 = Reg1.Execute(objMail.Subject)

For Each M In M1

' M.SubMatches(1) is the (\w*) in the pattern

' use M.SubMatches(2) for the second one if you have two (\w*)

Debug.Print M.SubMatches(1)

Next

End If

End Sub

================================================================

 

[TAVatPCU]

Ooops, attached image is slightly wrong. I was tweaking to no avail. Code is this: Set M1 = Reg1.Execute(objMail.Subject)

 

[Diane Poremsky]

I have not tested this - but it should work (fingers crossed )




The code sample prints to the debugger. We really should assign it to a string, but it will work it use it directly in the subject.

 
 

 
 
Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem
Dim moveCal As AppointmentItem
 
 

Set objAppt = Application.CreateItem(olAppointmentItem)
 
 
Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")
 
 

For Each objMail In Application.ActiveExplorer.Selection
 
 

Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "Subject[:](\w*)\s*\n"
.Global = True
End With
If Reg1.test(objMail.Body) Then
Set M1 = Reg1.Execute(objMail.Subject)
For Each M In M1
' M.SubMatches(1) is the (\w*) in the pattern
' use M.SubMatches(2) for the second one if you have two (\w*)
Debug.Print M.SubMatches(1)

Next
End If
 
 

 
 

 
 
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
objAppt.Subject = "Copied: " & M.SubMatches(1)
 
 
objAppt.Start = objMail.ReceivedTime + 3
objAppt.Save
'Move it using this method:
Set moveCal = objAppt.Move(CalFolder)
'Then display:
moveCal.Display
 
 

 
 

Next
Set objAppt = Nothing
Set objMail = Nothing
'MsgBox ("added to Calendar-Systems Schedules")
End Sub

 

[TAVatPCU]

Sorry no luck. Getting Run-time error '91': Object variable or With block variable not set.

 

[TAVatPCU]

I would like the original subject line moved to location. Thus the line of: objAppt.Location = "Copied: " & objMail.Subject

Then I tried this: objAppt.Subject = M.SubMatches(1)

Still no luck. Still getting -- Getting Run-time error '91': Object variable or With block variable not set. Sorry trying to learn and read on this topic at the same time. Getting confused.

Sub ConvertMailtoAccountAppt()

Dim objAppt As Outlook.AppointmentItem

Dim objMail As Outlook.MailItem

Dim moveCal As AppointmentItem

Set objAppt = Application.CreateItem(olAppointmentItem)

Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")

For Each objMail In Application.ActiveExplorer.Selection

Dim Reg1 As RegExp

Dim M1 As MatchCollection

Dim M As Match

Set Reg1 = New RegExp

' \s* = invisible spaces

' \d* = match digits

' \w* = match alphanumeric

With Reg1

> Pattern = "Subject[:](\w*)\s*\n"

> Global = True

End With

If Reg1.test(objMail.Body) Then

Set M1 = Reg1.Execute(objMail.Subject)

For Each M In M1

' M.SubMatches(1) is the (\w*) in the pattern

' use M.SubMatches(2) for the second one if you have two (\w*)

Debug.Print M.SubMatches(1)

Next

End If

objAppt.Subject = objMail.Subject

'sets it for recd. time AND not tomorrow at 9 AM per sample

objAppt.Start = objMail.ReceivedTime

objAppt.Body = objMail.Body

objAppt.ReminderSet = False

'objAppt.Move CalFolder

'objAppt.Display

objAppt.Location = "Copied: " & objMail.Subject

'objAppt.Subject = " "

objAppt.Subject = M.SubMatches(1)

objAppt.Start = objMail.ReceivedTime

objAppt.Save

'Move it using this method:

Set moveCal = objAppt.Move(CalFolder)

'Then display:

moveCal.Display

Next

Set objAppt = Nothing

Set objMail = Nothing

'MsgBox ("added to Calendar-Systems Schedules")

End Sub

 

[Diane Poremsky]

That's on the subject line?




Try this -




Add to the top, with the other Dims:


Dim strSubject As String




Replace debug.print line with this:
strSubject = M.SubMatches(1)




put strSubject in the subject line.
objAppt.subject = "Copied: " & strSubject

 

[TAVatPCU]

So sorry still not working. See attached images. It just does not seem to find the pattern. The word Subject: is in the body of the message.

 

[TAVatPCU]

Thanks for being so patient. I have hunted the www and still can't determine where I may have gone wrong. Any thoughts? Thanks so much.