howto check if there already are an appointment on day/time

Guest · Jun 21, 2006

I need some help with a little code that can search my calendar for excisting
appointments and if there are one thats on the same date that the one I'm
going to create, check if the timespan for the excisting appointment crash
with the new one.
i need 1/2 a hour between the appointments.
if there are a crash, I need to create a mail ( the subject and all that I
will figure out) and send it incl. to a cc.

I have the code for if the appointments are the same, based on billing
information w.m.
and the code for creating the appointment.
so the only thing I need are to figure uot how to compair the appointments...

best regards

jaran

Sue Mosher [MVP-Outlook] · Jun 21, 2006

See http://www.outlookcode.com/d/finddate.htm for samples that show how to use the Find method to search for appointments within a date/time range.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers

Guest · Jun 22, 2006

When I uses the code over and puts in two variables with dates (01.01.2006
and 31.12.2006) (i'm a norwegian so the date format differ from usa format,
but in the end it gives a readable format anyway)
the function returns all entries in my calendar before 2006, not the span I
want...

same happened when I used the string in a restrict method.

I tried this with the function because I allway want it to search the "this
year", but the year changes:
Set colcal = mpfCalendar.Items
stDateSp = "01.01." & Year(Date)
endDateSp = "31.12. " & Year(Date)
Set restrCalendar = DateSpan(colcal, stDateSp, endDateSp)

I can't understand why it does not returns anything but the appointments
before 2006
ie. my mothers birthday thats configured through a contact item.

best regards

jaran

Sue Mosher [MVP-Outlook] · Jun 22, 2006

Can you show more of the exact code you're using?

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers

Guest · Jun 23, 2006

I know this is a heavy not good written macro, but i'm a still much to learn
novice and have done what works first and then I will clean it up later...
main issue are to get it working...
need the restrictions so i don't get any out of data range errors and more...
the script shall create appointments from (new)e-mail, check if there
already any items that match, change if so, else create a new item... if
there already an appointment in the timespan, It shall send a e-mail and
create some kind of warning (not finnished).
hopefully you can read it.... some text are norwegian but not the code itself.

best regards

jaran

Public Sub Create_Appointment_from_eMail()
Dim myOlApp As Outlook.Application
Dim mpfInbox As Outlook.MAPIFolder
Dim mpfCalendar As Outlook.MAPIFolder
Dim restrCalendar As Outlook.Items
Dim colcal As Outlook.Items
Dim eMailobj As Outlook.mailItem
Dim myDestFolder As Outlook.MAPIFolder
Dim myApptItems As Outlook.AppointmentItem
Dim stDateStr As String
Dim stTimeStr As String
Dim DurationStr As String
Dim SubjStr As String

'Avtale variabler
Dim apptStartOppdrag As String
Dim apptVarighet As String
Dim apptAdresse As String
Dim apptSelger As String
Dim apptSelgerTlf As String
Dim apptMegler As String
Dim apptMeglerTlf As String
Dim apptOppdragsNR As String
Dim apptBestNR As String
Dim apptOppdragsType As String

'SÃ¸kevariabler
Dim srchOppDragsTypeStr As String
Dim srchDateStr As String
Dim srchAddressStr As String
Dim srchSubjStr As String
Dim srchSenderStr As String
Dim srcheMailBodyStr As String

Dim stDateSp As Date
Dim endDateSp As Date

srchSubjStr = "Bekreftelse fra Visningsfilm" '
Setter SÃ¸kestrengen for subjektfeltet
srchSenderStr = "(e-mail address removed)" ' Setter
avsenderadressen pÃ¥ de mail som skal sÃ¸kes i
srchDateStr = "UtfÃ¸ringsdato"
srchAddressStr = "Oppdragsadr"
srchoppdragstype = "Fotopakke"

' Setter verdier for e-post
Set myOlApp = CreateObject("Outlook.Application")
Set mpfInbox = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set myDestFolder = mpfInbox.Folders("Visningsfilm")
Set mpfCalendar =
myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)

Set colcal = mpfCalendar.Items
stDateSp = "01.01." & Year(Date)
endDateSp = "31.12. " & Year(Date)
Set restrCalendar = DateSpan(colcal, stDateSp, endDateSp)

For i = 1 To mpfInbox.Items.Count
' Loop all items in the Inbox\Test Folder
If mpfInbox.Items(i).Class = olMail And mpfInbox.Items(i).UnRead = True Then

Set eMailobj = mpfInbox.Items.Item(i)
If eMailobj.SenderEmailAddress Like srchSenderStr And _
Left(eMailobj.Subject, 28) Like srchSubjStr Then
eMailobj.FlagIcon = olYellowFlagIcon
'Set the yellow flag icon
eMailobj.BodyFormat = olFormatHTML

'Leter etter dato og klokkeslett i mailen
tbs = 1
tbs = InStr(tbs, eMailobj.Body, srchDateStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "klokken", vbTextCompare)
tbe2 = InStr(tbs, eMailobj.Body, "Selger", vbTextCompare)
tbs2 = tbe + 8
tbe2 = tbe2 - 4
tbs = tbs + 14
tbe = tbe - 2
x = tbe - tbs
x2 = tbe2 - tbs2
stDateStr = Format(Mid(eMailobj.Body, tbs, x), mmddyyyy)
stTimeStr = Format(Mid(eMailobj.Body, tbs2, x2), ttttt)
startoppdrag = stDateStr & " " & stTimeStr

'Leter frem selger og selgers telefonnummer
srcheMailBodyStr = "Selger:"
tbs = InStr(tbs, eMailobj.Body, srcheMailBodyStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "(tlf", vbTextCompare)
tbs = tbs + 9
tbe = tbe - 1
x = tbe - tbs
apptSelger = Mid(eMailobj.Body, tbs, x)
srcheMailBodyStr = "tlf:"
tbs = InStr(tbs, eMailobj.Body, srcheMailBodyStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "/", vbTextCompare)
tbe2 = InStr(tbs, eMailobj.Body, ")", vbTextCompare)
tbs2 = tbe + 6
tbs = tbs + 4
tbe = tbe
x = tbe - tbs
x2 = tbe2 - tbs2
apptSelgerTlf = "Telefon Hjem:" & Chr(9) & Chr(9) &
Format(Mid(eMailobj.Body, tbs, x), "##########") & _
vbNewLine & Chr(9) & "Mobil:" & Chr(9) &
Chr(9) & Chr(9) & Format(Mid(eMailobj.Body, tbs2, x2), "##########")

'leter frem meglers navn og telefonnummer
srcheMailBodyStr = "Ansvarlig megler:"
tbs = InStr(tbs, eMailobj.Body, srcheMailBodyStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "Megler tlf",
vbTextCompare)
tbs = tbs + 19
tbe = tbe - 4
x = tbe - tbs
apptMegler = Mid(eMailobj.Body, tbs, x)

'Leter frem Bestillingsnummer og ordrenummer.
srcheMailBodyStr = "Bestillingsnr:"
tbs = InStr(tbs, eMailobj.Body, srcheMailBodyStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "Oppdragsnr:",
vbTextCompare)
tbs = tbs + 16
tbe = tbe - 4
x = tbe - tbs
apptBestNR = Format(Mid(eMailobj.Body, tbs, x), "#####")

srcheMailBodyStr = "Oppdragsnr:"
tbs = InStr(tbs, eMailobj.Body, srcheMailBodyStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "Oppdragsadr:",
vbTextCompare)
tbs = tbs + 12
tbe = tbe - 4
x = tbe - tbs
apptOppdragsNR = Format(Mid(eMailobj.Body, tbs, x),
"##########")

'Leter frem adressen
tbs = InStr(tbs, eMailobj.Body, srchAddressStr,
vbTextCompare)
tbe = InStr(tbs, eMailobj.Body, "NÃ¸kler", vbTextCompare)
tbs = tbs + 14
tbe = tbe - 4
x = tbe - tbs
apptAdresse = Mid(eMailobj.Body, tbs, x)

'Leter etter oppdragstype og setter varighet ut fra dette
'Setter oppdrag og antall bilder ut fra type oppdrag
tbs = InStr(tbs, eMailobj.Body, srchoppdragstype,
vbTextCompare)
tbs = tbs + 11
DurationStr = Mid(eMailobj.Body, tbs, 3)
If DurationStr Like "Ett" Then
apptVarighet = 45
apptOppdragsType = "Ett-Roms Pakke:" _
& vbNewLine & Chr(9) & "10
foto:" _
& Chr(9) & Chr(9) & Chr(9) &
" 3 detalj (kvadratiske)," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 1 fasade," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 2 miljÃ¸," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 4 eiendom (1 stÃ¥ende)"
ElseIf DurationStr Like "Sta" Then
apptVarighet = 60
apptOppdragsType = "Standard Pakke:" _
& vbNewLine & Chr(9) & "16
foto:" _
& Chr(9) & Chr(9) & Chr(9) &
" 3 detalj (kvadratiske),&" _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 1 fasade," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 2 miljÃ¸," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 10 eiendom (2 stÃ¥ende)"
ElseIf DurationStr Like "Her" Then
apptVarighet = 90
apptOppdragsType = "HerregÃ¥rdspakke:" _
& vbNewLine & Chr(9) & "25
foto" _
& Chr(9) & Chr(9) & Chr(9) &
" 3 detalj (kvadratiske)," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 2 fasade," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 4 miljÃ¸ (1 stÃ¥ende)," _
& vbNewLine & Chr(9) &
Chr(9) & Chr(9) & Chr(9) & " 16 eiendom (2 stÃ¥ende)"
End If

'Ser om det finnes en avtale pÃ¥ dato og klokkeslett og
hvis denne har samme adresse og blir den endret,
'hvis det finnes en avtale som ikke er lik blir det ikke
opprettet ny,
'men sendt mail til bestiller om at tidspunktet er
opptatt hvis ikke lages det en ny avtale

Set myApptItems = myOlApp.CreateItem(olAppointmentItem)
For i2 = 1 To restrCalendar.Count
stdateshort1 = startoppdrag
stdateshort2 = mpfCalendar.Items(i2).Start
enddateshort1 = mpfCalendar.Items(i2).End

If stdateshort1 > stdateshort2 And stdateshort1 <
enddateshort1 Then

MsgBox ("Det finnes allerede en avtale pÃ¥
dette tidspunktet pÃ¥ denne datoen, send mail")

If mpfCalendar.Items(i2).BillingInformation =
"Bestillingsnr:" & " " & apptBestNR & Chr(9) & "Oppdragsnr:" & apptOppdragsNR
Then
mpfCalendar.Items(i2).Start = startoppdrag
mpfCalendar.Items(i2).Duration = appvarighet
mpfCalendar.Items(i2).Body = Chr(9) _
& "Bestillingsnr:" & Chr(9) &
Chr(9) & Chr(9) & apptBestNR _
& vbNewLine & Chr(9) &
"Oppdragsnr:" & Chr(9) & Chr(9) & Chr(9) & apptOppdragsNR _
& vbNewLine & Chr(9) & "Selger:"
& Chr(9) & Chr(9) & Chr(9) & apptSelger _
& vbNewLine & Chr(9) &
apptSelgerTlf _
& vbNewLine & Chr(9) &
"Ansvarlig Megler:" & Chr(9) & apptMegler _
& vbNewLine & Chr(9) &
"Oppdragstype:" & Chr(9) & Chr(9) & apptOppdragsType
mpfCalendar.Items(i2).Save
End If
End If

Next
With myApptItems
.Start = startoppdrag
.Duration = apptVarighet
.Subject = "Fotografering
Visningsfilm/Privatmegleren"
.Location = apptAdresse
.BillingInformation = "Bestillingsnr:" & " "
& apptBestNR & Chr(9) & "Oppdragsnr:" & apptOppdragsNR
.Categories = ("Boligfoto - Visningsfilm")
'.FlagIcon = olBlueFlagIcon
' .BodyFormat = olFormatHTML
.Body = Chr(9) _
& "Bestillingsnr:" & Chr(9) & Chr(9)
& apptBestNR _
& vbNewLine & Chr(9) & "Oppdragsnr:"
& Chr(9) & Chr(9) & apptOppdragsNR _
& vbNewLine & Chr(9) & "Selger:" &
Chr(9) & Chr(9) & Chr(9) & apptSelger _
& vbNewLine & Chr(9) & apptSelgerTlf _
& vbNewLine & Chr(9) & "Ansvarlig
Megler:" & Chr(9) & apptMegler _
& vbNewLine & Chr(9) &
"Oppdragstype:" & Chr(9) & Chr(9) & apptOppdragsType
.Save
End With
Call SetApptColorLabel(myApptItems, 3)
With eMailobj
.Categories = ("Boligfoto - Visningsfilm")
.UnRead = False
.Move myDestFolder
End With
'.Save
errorh:

End If

End If

Next
End Sub
Sub SetApptColorLabel(objAppt As Outlook.AppointmentItem, _
intColor As Integer)
' requires reference to CDO 1.21 Library
' adapted from sample code by Randy Byrne
' intColor corresponds to the ordinal value of the color label
'1=Important, 2=Business, etc.
Const CdoPropSetID1 = "0220060000000000C000000000000046"
Const CdoAppt_Colors = "0x8214"
Dim objCDO As MAPI.Session
Dim objMsg As MAPI.Message
Dim colFields As MAPI.Fields
Dim objField As MAPI.Field
Dim strMsg As String
Dim intAns As Integer
On Error Resume Next

Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
If Not objAppt.EntryID = "" Then
Set objMsg = objCDO.GetMessage(objAppt.EntryID, _
objAppt.Parent.StoreID)
Set colFields = objMsg.Fields
Set objField = colFields.Item(CdoAppt_Colors, CdoPropSetID1)
If objField Is Nothing Then
Err.Clear
Set objField = colFields.Add(CdoAppt_Colors, vbLong, intColor,
CdoPropSetID1)
Else
objField.Value = intColor
End If
objMsg.Update True, True
Else
strMsg = "You must save the appointment before you add a color
label. " & _
"Do you want to save the appointment now?"
intAns = MsgBox(strMsg, vbYesNo + vbDefaultButton1, "Set Appointment
Color Label")
If intAns = vbYes Then
Call SetApptColorLabel(objAppt, intColor)
Else
Exit Sub
End If
End If

Set objAppt = Nothing
Set objMsg = Nothing
Set colFields = Nothing
Set objField = Nothing
objCDO.Logoff
Set objCDO = Nothing
End Sub

Function Quote(MyText)
Quote = Chr(34) & MyText & Chr(34)
End Function

Function DateSpan(colItems As Outlook.Items, _
dteStart As Date, dteEnd As Date) _
As Outlook.Items
Dim colSpanItems As Outlook.Items
On Error Resume Next
colItems.Sort "[Start]"
colItems.IncludeRecurrences = True
strFind = "[Start] <= " & _
Quote(Format(dteEnd, "ddddd") & " 11:59 PM") & _
" AND [End] > " & _
Quote(Format(dteStart, "ddddd") & " 12:00 AM")
'MsgBox strFind
Set colSpanItems = colItems.Restrict(strFind)
If Err = 0 Then
Set DateSpan = colSpanItems
End If
Set colSpanItems = Nothing
End Function

Sue Mosher [MVP-Outlook] · Aug 18, 2006

Sorry about the delay in getting back to you. What happens if you let the Msg strFind statement run? My guess is that the problem is in how you're supplying the dates, and that should confirm it.

Also, it really helps to get your question answered faster if you post only the code that is obviously directly relevant to the issue.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers

StoltHD said:
I know this is a heavy not good written macro, but i'm a still much to learn
novice and have done what works first and then I will clean it up later...
main issue are to get it working...
need the restrictions so i don't get any out of data range errors and more...
the script shall create appointments from (new)e-mail, check if there
already any items that match, change if so, else create a new item... if
there already an appointment in the timespan, It shall send a e-mail and
create some kind of warning (not finnished).
hopefully you can read it.... some text are norwegian but not the code itself.

best regards

Set myOlApp = CreateObject("Outlook.Application")
Set mpfCalendar =
myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)

Set colcal = mpfCalendar.Items
stDateSp = "01.01." & Year(Date)
endDateSp = "31.12. " & Year(Date)
Set restrCalendar = DateSpan(colcal, stDateSp, endDateSp)

Function DateSpan(colItems As Outlook.Items, _
dteStart As Date, dteEnd As Date) _
As Outlook.Items
Dim colSpanItems As Outlook.Items
On Error Resume Next
colItems.Sort "[Start]"
colItems.IncludeRecurrences = True
strFind = "[Start] <= " & _
Quote(Format(dteEnd, "ddddd") & " 11:59 PM") & _
" AND [End] > " & _
Quote(Format(dteStart, "ddddd") & " 12:00 AM")
'MsgBox strFind
Set colSpanItems = colItems.Restrict(strFind)
If Err = 0 Then
Set DateSpan = colSpanItems
End If
Set colSpanItems = Nothing
End Function

howto check if there already are an appointment on day/time

Guest

Sue Mosher [MVP-Outlook]

Guest

Sue Mosher [MVP-Outlook]

Guest

Sue Mosher [MVP-Outlook]