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

Status
Not open for further replies.

TAVatPCU

Member
Outlook version
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Member
Outlook version
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Code:
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

Member
Outlook version
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Re: the Subject question - yes you can do it, but isn't that the same subject as in the email?
 

TAVatPCU

Member
Outlook version
Email Account
Exchange Server
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.
 

TAVatPCU

Member
Outlook version
Email Account
Exchange Server
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

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

Attachments

  • GetValueUsingRegEx.jpg
    GetValueUsingRegEx.jpg
    96.3 KB · Views: 386

TAVatPCU

Member
Outlook version
Email Account
Exchange Server
Ooops, attached image is slightly wrong. I was tweaking to no avail. Code is this: Set M1 = Reg1.Execute(objMail.Subject)
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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.




Code:

 
 

 
 
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

Member
Outlook version
Email Account
Exchange Server
Sorry no luck. Getting Run-time error '91': Object variable or With block variable not set.
 

TAVatPCU

Member
Outlook version
Email Account
Exchange Server
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.: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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

Member
Outlook version
Email Account
Exchange Server
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.
CodeAndMessageToCopyToAppt.jpgNewApptNoPatternFound.jpg
 

TAVatPCU

Member
Outlook version
Email Account
Exchange Server
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.
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
Mark Foley The upload of "Calendar" failed. There was a problem with the request. Using Outlook 6
Potty Ash MS Outlook 2010 custom form - validation or formula to request user to check a checkbox Outlook VBA and Custom Forms 16
S Accepting meeting request from calendar keeps the meeting request in the inbox Using Outlook 2
D Add all meeting rooms to the meeting request by default Outlook VBA and Custom Forms 0
G Auto accept meeting request for non primary account Outlook VBA and Custom Forms 1
T Double clik behavior on agenda open a new meeting request Using Outlook 1
Diane Poremsky Autoaccept a Meeting Request using Rules Using Outlook 2
Diane Poremsky iPhone and the Meeting Request Bug Using Outlook 0
Y Creating custom appointment request form with multiple mail recipients Outlook VBA and Custom Forms 5
Diane Poremsky Task Request Status Update Address Missing Using Outlook 0
Diane Poremsky How to Create a Pick-a-Meeting Request Using Outlook 0
D Meeting Request - Too Many Recipients Using Outlook 0
D Leave Calendar Request Triggers To Supervisors Using Outlook 1
O How to send outlook meeting request as attachment Using Outlook 3
I Multiple events in single request Using Outlook 6
N Outlook meeting request decline behavior Using Outlook 1
S Open custom meeting request with checkbox Using Outlook 0
D Restore Delete Calendar Meeting Request Using Outlook 3
S signature in meeting request Using Outlook 2
J How create an .ics file with a multiple apointment request Using Outlook 0
M Room Reservation request showed "None" in Tracking-View Tracking Status. Exchange Server Administration 0
A Issue with respond to an email message with a meeting request Using Outlook 0
O Outlook Holiday Request Form Design Using Outlook 0
F Creating Meeting Request Custom form and distribute it to domain user HELP!!! Using Outlook 0
F Creating Meeting Request Custom form and distribute it to domain user HELP!!! Using Outlook 0
J Holiday request form Using Outlook 7
G Request Form Using Outlook 2
J Exclude myself in meetin request Using Outlook 0
J Outlook Contacts: How to filter contact phone numbers from a cti request Using Outlook 1
J outlook meeting request random people are deleted Using Outlook 2
R How to show Sent Date in Meeting Request printouts Using Outlook 1
P Not able to receive meeting request Using Outlook 2
G Autoaccept/autodeny meeting request after crosscheck with calendar Using Outlook 1
B Outlook Calendar - Time zone changes after the meeting request is accepted. Using Outlook 1
L Need to Delete One Attendee from Meeting Request Without Resending the Request Using Outlook 1
R Disable request to share a calendar Using Outlook 1
P Time Off Request - not posting to public folder once approved Using Outlook 0
E Outlook invitation request mail sending twice problem Using Outlook 1
M How can I send task request using vCalender/VTodo component using C# Using Outlook 2
M How can I send a Task Request using vCalender/vTodo format using C# Using Outlook 3
K Print "scheduling assistant" data on meeting request? Using Outlook 1
D Sending Multiple Meeting Dates in One Meeting Request Using Outlook 4
Diane Poremsky Error: 5102. Server. Maximum request length exceeded Using Outlook.com accounts in Outlook 0
S use the custom form to show meeting request in recipient's calendar Outlook VBA and Custom Forms 1
D Tracking meeting request responses in Outlook Outlook VBA and Custom Forms 16
T Custom Task Request Deployment Outlook VBA and Custom Forms 5
D 2d help request-problems sharing BCM database BCM (Business Contact Manager) 1
E Strange save request when closing Outlook 2007 Outlook VBA and Custom Forms 4
E Strange save request when closing Outlook 2007 Outlook VBA and Custom Forms 4
M Create editable meeting request with attendees from .ics Outlook VBA and Custom Forms 3

Similar threads

Top