UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
9 Pages V « < 7 8 9  (Go to first unread post)
   Reply to this topicStart new topic
> Ms Outlook Style Calendar For Access Projects, Access 2003    
 
   
Peter Hibbs
post Mar 15 2019, 11:43 AM
Post#161


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi basehumax,

Well I don't know but I would guess that you have the constant QUOTE defined twice in the database. Try searching the VBA modules for the word QUOTE and see if it appears twice as a Constant declaration at the top of two different VBA modules.

If it does, and the definition is the same for both (i.e. Public Const QUOTE = """") then you can delete one of them. If it does but they are different then you will need to change one of them to a different name and then change the code to match that new name where it applies.

HTH

Peter Hibbs.
Go to the top of the page
 
basehumax
post Mar 16 2019, 12:33 AM
Post#162



Posts: 40
Joined: 17-June 18



Hi peter

Thanks for you replay i am still confused please help here is the codes

Option Compare Database
Option Explicit

Dim vDateTime As Date

Private Sub cboCategory_AfterUpdate()
Me.lblCategory.BackColor = Me.cboCategory.Column(2)
End Sub

Private Sub cboEndTime_AfterUpdate()

If Me.cboEndTime = 0 Then 'if user selects midnight as End Time then @@@ Add these 3 lines @@@
Me.txtEndDate = Me.txtEndDate + 1 'inc Date to next day
End If
Me.chkSave = True

End Sub

Private Sub cboEndTime_KeyPress(KeyAscii As Integer)
If Chr(KeyAscii) = ";" Or Chr(KeyAscii) = "," Or Chr(KeyAscii) = "." Then KeyAscii = Asc(":") 'allow users to enter ; or , or . instead of :
If Chr(KeyAscii) Like "[!0-9:]" And KeyAscii <> vbKeyBack Then KeyAscii = 0
End Sub

Private Sub cboStartTime_AfterUpdate()

Me.cboEndTime = DateAdd("n", conPeriod, Me.cboStartTime)
Me.chkSave = True

End Sub

Private Sub cboStartTime_KeyPress(KeyAscii As Integer)
If Chr(KeyAscii) = ";" Or Chr(KeyAscii) = "," Or Chr(KeyAscii) = "." Then KeyAscii = Asc(":") 'allow users to enter ; or , or . instead of :
If Chr(KeyAscii) Like "[!0-9:]" And KeyAscii <> vbKeyBack Then KeyAscii = 0
End Sub

Private Sub chkAllDay_AfterUpdate()

If Me.chkRecurSingle = False Then 'if chkRecurSingle flag = True then keep time combos hidden
Me.cboStartTime.Visible = Not Me.chkAllDay
Me.cboEndTime.Visible = Not Me.chkAllDay
End If
Me.chkSave = True

End Sub

Private Sub cmdClose_Click()

Dim vRet As Long

If Me.chkSave = True Then
vRet = MsgBox("Do you want to save changes?", vbExclamation + vbYesNoCancel, "Save Appointment")
If vRet = vbCancel Then Exit Sub
If vRet = vbYes Then
Exit Sub 'save appt, abort if error
End If
End If
DoCmd.Close acForm, Me.Name

End Sub

Private Sub cmdDelete_Click()

'Delete selected appointment record

If Nz(Me.txtPattern) <> "" And Me.chkRecurSingle = True Then 'if recurring appt and sequence mode then
If MsgBox("Are you sure you want to delete this appointment and ALL the associated recurring appointments?", vbQuestion + vbYesNo, "Delete Recurring Appointments") = vbNo Then Exit Sub
CurrentDb.Execute "DELETE FROM tblAppointments WHERE RecurrenceID = " & Me.lstAppts.Column(9) 'delete all recurring records in group
Else
If MsgBox("Are you sure you want to delete this appointment?", vbQuestion + vbYesNo, "Delete Appointment") = vbNo Then Exit Sub 'request confirmation
CurrentDb.Execute "DELETE FROM tblAppointments WHERE ApptID = " & Me.txtAppointmentID 'delete session record
End If
gDummy = 1 'return 1 (refresh screen on return)
DoCmd.Close acForm, Me.Name 'and close form

End Sub

Private Sub cmdRecur_Click()

'Open form frmRecurrences and select a recurring pattern

Dim vDate As Date
Dim vDuration As Long

gDummy = Me.txtPattern 'save current pattern (if any)
DoCmd.OpenForm "frmRecurrences", , , , , acDialog, Me.txtStartDate & " " & Me.cboStartTime & "," & Me.txtEndDate & " " & Me.cboEndTime & "," & Me.lstAppts.Column(9)
If gDummy <> Nz(Me.txtPattern) Then 'if recurrence pattern changed then
Me.txtPattern = gDummy 'update txtPattern with new pattern
If gDummy <> "X" Then 'if user chose to keep recurrences then
vDate = Mid(Me.txtPattern, 1, 16) 'fetch new Start Date & Time
Me.txtStartDate = DateValue(vDate) 'and set Start Date
vDuration = Mid(Me.txtPattern, 29, 5) 'fetch appt duration (in minutes)
Me.txtEndDate = DateValue(DateAdd("n", vDuration, vDate)) 'calc End Date of appt
Me.cboEndTime = TimeValue(DateAdd("n", vDuration, vDate)) 'calc End Time of appt
Me.chkRecurSingle = True 'set Recurring mode
End If
Me.chkSave = True 'set Save flag
RecurringMode 'set up recurring/normal conditions
End If

End Sub

Private Sub cmdNew_Click()

'Create a new appointment record

Me.chkUpdate = False 'clear chkUpdate flag if user is starting a new appt
ClearControls 'reset main controls
EnableFields True 'enable input fields
Me.txtAppointmentID = 0 'reset AppointmentID
Me.lstAppts = Null 'clear any selections in list box
Me.txtStartDate.SetFocus 'move focus to Start Date

Me.cmddelete.Enabled = False
Me.cmdSave.Enabled = False

End Sub

Private Sub cmdSave_Click()

Dim vCategoryID As Long


If Nz(Me.cboCategory) = "" Then 'if 'All Categories' mode then
DoCmd.OpenForm "frmCategorySelect", , , , , acDialog 'open frmCategorySelect form for user to select a Category
If gDummy = 0 Then Exit Sub 'abort if user cancels
Me.cboCategory = gDummy 'copy CategoryID to vCategoryID
End If






' If Me.txtCategoryID = "*" Then 'if 'All Categories' mode then
' If Me.chkUpdate = False Then 'if user starting new appt then
' DoCmd.OpenForm "frmCategorySelect", , , , , acDialog 'open frmCategorySelect form for user to select a Category
' If gDummy = 0 Then Exit Sub 'abort if user cancels
' vCategoryID = gDummy 'copy CategoryID to vCategoryID
' Else 'if user is changing an existing appt then
' vCategoryID = Me.lstAppts.Column(13) 'fetch CategoryID for selected appt
' End If
' Else 'if Category specified then
' vCategoryID = Me.txtCategoryID 'copy Me.txtCategoryID to vCategoryID
' End If

If SaveAppointment(Nz(Me.cboCategory)) = True Then Exit Sub 'save appt, abort if error
DoCmd.Close acForm, Me.Name 'and close form

End Sub

Private Sub Form_Open(Cancel As Integer)

'OpenArgs = (Date & Time) + (Offset from top of calling form) + (CategoryID)

Dim vArray() As String
Dim vEndTime As Date

On Error GoTo ErrorCode

vArray = Split(OpenArgs, ",")

vDateTime = CDate(vArray(0)) 'fetch appointment date/time from OpenArgs
Me.Move Me.WindowLeft, vArray(1) 'adjust form vertical posn to fit on Calendar form
Me.txtCategoryID = vArray(2) 'fetch CategoryID (or * if all categories)

ComboBoxTimes Me.cboStartTime, "00:00:00", conPeriod 'set up time slot times for StartTime
ComboBoxTimes Me.cboEndTime, "00:" & conPeriod & ":00", conPeriod 'and EndTime (+ conPeriod for end times)

vEndTime = DateAdd("n", 1, vDateTime) 'set vEndTime to EndDate + 1 second
Me.txtStartDate = DateValue(vDateTime) 'show default appt start date
Me.txtEndDate = DateValue(vDateTime) 'show default appt end date
Me.cboStartTime = TimeValue(vDateTime) 'and default Start Time
Me.cboEndTime = DateAdd("n", conPeriod, Me.cboStartTime) 'and default End Time
Me.txtApptDate = Format(Me.txtStartDate, "dddd") & " " & Format(Me.txtStartDate, "Long Date") 'update main date field
Me.lstAppts.Requery

If vArray(2) = "*" Then
Me.txtApptDate = Me.txtStartDate & " for All Categories"
Else
Me.txtApptDate = Me.txtStartDate & " for " & DLookup("CategoryName", "tblCategories", "CategoryID Like '" & Me.txtCategoryID & "'") 'show date AND Category name
Me.cboCategory = vArray(2) 'set default Category to current category selection
End If

gDummy = 0 'return 0 (no changes made)
Exit Sub

ErrorCode:
MsgBox err.Description

End Sub

Private Sub lstAppts_Click()

'User clicks on an appt in List box

Me.chkUpdate = True 'set chkUpdate if user selects an existing appt for modification
FetchAppointmentData Me.lstAppts 'enable input fields and fill with data from list box, etc

End Sub

Public Sub FetchAppointmentData(vApptID As Long)

'Copy selected appt data from list box to text fields

Dim vText As String

Me.txtAppointmentID = vApptID 'update txtAppointmentID
EnableFields True 'enable input fields
Me.cmdSave.Enabled = True 'enable Save btn
Me.cmddelete.Enabled = True 'enable Delete btn
Me.cmdRecur.Enabled = True 'enable Recurrence btn

Me.txtStartDate = DateValue(Me.lstAppts.Column(1)) 'and Start Date
Me.txtEndDate = DateValue(Me.lstAppts.Column(2)) 'and End Date
Me.cboStartTime = TimeValue(Me.lstAppts.Column(1)) 'and Start Time
Me.cboEndTime = TimeValue(Me.lstAppts.Column(2)) 'and End Time
Me.txtSubject = Me.lstAppts.Column(4) 'and subject
Me.txtLocation = Me.lstAppts.Column(5) 'and location
Me.cboCategory = Me.lstAppts.Column(13) 'and Category
Me.lblCategory.BackColor = Me.lstAppts.Column(14) 'and Category color

Me.txtNotes = Nz(DLookup("ApptNotes", "tblAppointments", "ApptID = " & Me.txtAppointmentID)) 'fetch notes from table (use DLookup coz List box cannot store > 255 chrs)
Me.chkSave = False 'reset Save flag if changing appts

If Me.lstAppts.Column(10) = False Then 'if NOT All Day Event then
Me.chkAllDay = False 'clear chk box
Else 'if All Day Event then
Me.chkAllDay = True 'tick chk box
Me.cboStartTime.Visible = False 'hide Time combos
Me.cboEndTime.Visible = False
End If

If Me.lstAppts.Column(9) > 0 Then 'if user selects a recurring appt
vText = "This is one appointment in a series." & vbCrLf & "What do you want to open?"
DoCmd.OpenForm "frmRecurrenceSelect", , , , , acDialog, vText 'select option to open single appt or series
If gDummy = 1 Then 'select type
Me.chkRecurSingle = True 'flag as Series
Else
Me.chkRecurSingle = False 'flag as Single
Me.cmdRecur.Enabled = False 'disable Recurrence btn for a Single appt of a recurring series
End If
Me.txtPattern = Me.lstAppts.Column(8) 'fetch recurring pattern from table
Else
Me.txtPattern = "" 'set Normal appt mode
Me.chkRecurSingle = False 'reset flag if not Recurring Series appts
End If

Me.Label34.Visible = False
RecurringMode 'enable Recurring mode

End Sub

Public Sub EnableFields(vMode As Boolean)

'Reset input fields to default values and disable
'Entry (vMode) = True to enable controls, = False to disable controls

Me.cboStartTime.Enabled = vMode 'enable (and unhide) main input controls
Me.cboStartTime.Visible = vMode
Me.cboEndTime.Enabled = vMode
Me.cboEndTime.Visible = vMode
Me.txtStartDate.Enabled = vMode
Me.txtStartDate.Visible = vMode
Me.txtEndDate.Enabled = vMode
Me.txtEndDate.Visible = vMode
Me.txtSubject.Enabled = vMode
Me.txtLocation.Enabled = vMode
Me.txtNotes.Enabled = vMode
Me.chkAllDay.Enabled = vMode
Me.chkAllDay.Visible = vMode
Me.cboCategory.Enabled = vMode
If Nz(Me.cboCategory.Column(2)) <> "" Then Me.lblCategory.BackColor = Me.cboCategory.Column(2)

End Sub

Private Sub txtEndDate_AfterUpdate()
Me.chkSave = True 'reset Save flag if changing appts
End Sub

Private Sub txtLocation_AfterUpdate()

Me.cmdSave.Enabled = True
Me.txtLocation = Replace(Me.txtLocation, """", "''") 'replace any double quotes with two single quotes
Me.chkSave = True 'reset Save flag if changing appts

End Sub

Private Sub txtNotes_AfterUpdate()

Me.cmdSave.Enabled = True
Me.txtNotes = Replace(Me.txtNotes, """", "''") 'replace any double quotes with two single quotes
Me.chkSave = True 'reset Save flag if changing appts

End Sub

Private Sub txtStartDate_AfterUpdate()
Me.chkSave = True 'reset Save flag if changing appts
End Sub

Private Sub txtSubject_AfterUpdate()

Me.txtSubject = Replace(Me.txtSubject, """", "''") 'replace any double quotes with two single quotes
Me.cmdSave.Enabled = True
Me.chkSave = True 'reset Save flag if changing appts

End Sub

Public Function CheckDates() As Boolean

'Check if the selected end date/time is later than the selected start date/time, return True if error

Dim vNewStart As Date, vNewEnd As Date

vNewStart = Me.txtStartDate & " " & Me.cboStartTime 'combine new start date and time
vNewEnd = Me.txtEndDate & " " & Me.cboEndTime 'combine new end date and time
If vNewEnd <= vNewStart Then 'if End Date/Time <= Start Date/Time then
Beep
MsgBox "ERROR. The Start Date and Time must be earlier than the End Date and Time. Please enter new values for the date/time fields.", vbCritical + vbOKOnly, "Invalid Date/Time Fields"
CheckDates = True 'return True if dates/times in error
Exit Function
End If
Me.cmdSave.Enabled = True 'enable Save btn if dates & times valid

End Function

Public Function SaveAppointment(vCategoryID As Long) As Boolean

'Save new or amended appointment data to tblAppointments table
'Entry (vCategoryID) = CategoryID of category for the appt

Dim vAppointmentID As Long, vRecurID As Long, vDuration As Long, vCount As Long
Dim vNewStart As Date, vNewEnd As Date
Dim vApptInfo As String

On Error GoTo ErrorCode

'Check if appt start time is earlier than appt end time
If CheckDates = True Then SaveAppointment = True: Exit Function 'return True if error found

'Check if Subject field empty and error if it is
If Nz(Me.txtSubject) = "" Then 'if no Subject text then
Beep
MsgBox "ERROR, you must enter some text in the Subject field before saving the appointment.", vbCritical + vbOKOnly, "Invalid Subject Field"
Me.txtSubject.SetFocus 'move focus to Subject field
SaveAppointment = True
Exit Function 'and exit
End If

If Me.chkAllDay = False Then 'if normal event (not All Day) then
vNewStart = Me.txtStartDate + Me.cboStartTime 'combine new start date and time
vNewEnd = Me.txtEndDate + Me.cboEndTime 'combine new end date and time
Else 'if an All Day Event then
vNewStart = Me.txtStartDate + TimeValue(conFirstTime) 'set Start Date to Start Date + conFirstTime
vNewEnd = Me.txtEndDate + TimeValue(conLastTime) 'set End Date to End Date + LastTime
vNewEnd = DateAdd("n", conPeriod, vNewEnd) 'and add appt period in conPeriod
End If

'Check if new (or amended) appointment overlaps an existing appointment
If conMultiAppts = 1 Then 'if multiple appts for a time slot is NOT allowed then
If Nz(Me.txtPattern) = "" Or Me.chkRecurSingle = False Then 'if normal Single appt or recurring appt in single mode then
vAppointmentID = AppointmentsCheck(vNewStart, vNewEnd, Me.txtAppointmentID, 0, vCategoryID) 'fetch ID of overlapped appt (if any)
If vAppointmentID > 0 Then 'if function returns value >0 then
vApptInfo = DLookup("ApptSubject & Chr(13) & Chr(10) & 'Date/Time = ' & ApptStart & ' to ' & ApptEnd", "tblAppointments", "ApptID = " & vAppointmentID) 'fetch info on existing appt
MsgBox "ERROR. This new appointment overlaps an existing appointment :-" & vbCrLf & "Subject = " & vApptInfo & vbCrLf & vbCrLf & "Please amend dates and/or times and try again.", vbCritical + vbOKOnly, "Invalid Appointment Times"
SaveAppointment = True
Exit Function
End If
End If
End If

If Me.txtPattern = "X" Then 'if user Removes recurring appt then convert recurring appt back to single appt
vRecurID = Me.lstAppts.Column(9) 'fetch current RecurrenceID value
vApptInfo = Me.lstAppts.Column(8) 'fetch original recurrence pattern
CurrentDb.Execute "DELETE FROM tblAppointments WHERE RecurrenceID = " & vRecurID 'delete all recurring appts first
vNewStart = Mid(vApptInfo, 1, 16) 'and fetch original Start Date/Time
vDuration = Mid(vApptInfo, 29, 5) 'and original duration (in minutes)
vNewEnd = DateAdd("n", vDuration, vNewStart) 'add duration to vNewStart to get original End Date/time

CurrentDb.Execute "INSERT INTO tblAppointments (ApptSubject, ApptLocation, ApptStart, ApptEnd, ApptNotes, CategoryID) VALUES (" _
& QUOTE & Me.txtSubject & QUOTE & ", " _
& QUOTE & Me.txtLocation & QUOTE & ", " _
& Format(vNewStart, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& Format(vNewEnd, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& QUOTE & Me.txtNotes & QUOTE & ", " _
& vCategoryID & ")" 'and insert new record into tblAppointments
Else
'If txtAppointmentID = 0 then add a new appointment, if txtAppointmentID > 0 then amend the existing appointment
If Me.txtAppointmentID = 0 Then 'if no existing appointment record found then
If vNewStart < Now Then 'if new appt time is earlier than Now() then
Beep
If MsgBox("WARNING. This appointment is in the past, do you really want to create this appointment now?", vbQuestion + vbYesNo, "Invalid Appointment Time") = vbNo Then Exit Function
End If

If Nz(Me.txtPattern) = "" Then 'if normal Single appt then
CurrentDb.Execute "INSERT INTO tblAppointments (ApptSubject, ApptLocation, ApptStart, ApptEnd, AllDayEvent, ApptNotes, CategoryID) VALUES (" _
& QUOTE & Me.txtSubject & QUOTE & ", " _
& QUOTE & Me.txtLocation & QUOTE & ", " _
& Format(vNewStart, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& Format(vNewEnd, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& IIf(Me.chkAllDay = True, -1, 0) & ", " _
& QUOTE & Me.txtNotes & QUOTE & ", " _
& vCategoryID & ")" 'and insert new record into tblAppointments
Else 'if Recurring appt then
vCount = InsertRecurringAppts(Me.txtPattern, vRecurID, False, vCategoryID) 'count number of appts that will clash
If vCount > 0 Then 'if any found then
SaveAppointment = True
Me.chkSave = False
Beep
If MsgBox("WARNING. There are " & vCount & " scheduled appointments which will clash with the new recurring appointments, do you want to schedule the new appointments anyway?", vbQuestion + vbYesNo, "Overlapping Appointments Warning") = vbNo Then Exit Function
End If
vRecurID = Nz(DMax("RecurrenceID", "tblAppointments"), 0) + 1 'calc next RecurrenceID value
InsertRecurringAppts Me.txtPattern, vRecurID, True, vCategoryID 'add new recurring appt records
End If
Else 'if changing an existing appointment record then
If Nz(Me.txtPattern) = "" Or Me.chkRecurSingle = False Then 'if normal Single appt or recurring appt in single mode then
CurrentDb.Execute "UPDATE tblAppointments SET " _
& "ApptSubject = " & QUOTE & Me.txtSubject & QUOTE & ", " _
& "ApptLocation = " & QUOTE & Me.txtLocation & QUOTE & ", " _
& "ApptStart = " & Format(vNewStart, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& "ApptEnd = " & Format(vNewEnd, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& "ApptNotes = " & QUOTE & Me.txtNotes & QUOTE & ", " _
& "AllDayEvent = " & IIf(Me.chkAllDay = True, -1, 0) & ", " _
& "CategoryID = " & vCategoryID & " " _
& "WHERE ApptID = " & Me.txtAppointmentID 'update existing appointment with amended data
Else 'if updating Recurring appt then
vRecurID = Me.lstAppts.Column(9) 'fetch current RecurrenceID value
If vRecurID = 0 Then 'if there is no RecurrenceID (i.e. non-recurring appt converted to recurring appt) then
vRecurID = Nz(DMax("RecurrenceID", "tblAppointments"), 0) + 1 'calc next RecurrenceID value
CurrentDb.Execute "DELETE FROM tblAppointments WHERE ApptID = " & Me.txtAppointmentID 'and delete existing appt
End If

vCount = InsertRecurringAppts(Me.txtPattern, vRecurID, False, vCategoryID) 'count number of appts that will clash
If vCount > 0 Then 'if any found then
SaveAppointment = True
Me.chkSave = False
Beep
If MsgBox("WARNING. There are " & vCount & " scheduled appointments which will clash with the new recurring appointments, do you want to schedule the new appointments anyway?", vbQuestion + vbYesNo, "Overlapping Appointments Warning") = vbNo Then Exit Function
End If
CurrentDb.Execute "DELETE FROM tblAppointments WHERE RecurrenceID = " & vRecurID 'first delete all existing recurring appts
InsertRecurringAppts Me.txtPattern, vRecurID, True, vCategoryID 'add new recurring appt records
End If
End If
End If
gDummy = 1 'return 1 (refresh screen on return)
SaveAppointment = False
Exit Function

ErrorCode:
MsgBox err.Description
SaveAppointment = False

End Function

Public Function InsertRecurringAppts(vPattern As String, vRecurrenceID As Long, vMode As Boolean, vCategoryID As Long) As Long

'Insert new appt record for each recurring appt required
'Entry (vPattern) defines recurring pattern sequence
' (vRecurrenceID) = RecurrenceID to be used
' (vMode) = Check or Insert mode. (Check mode = False - Returns number of overlapping appts. = True - Inserts new appointments)
' (vCategoryID) = CategoryID of category for the appt
'Exit (InsertRecurringAppts) = If in Check mode then returns number of overlapping appts.

Dim vCount As Long, vMax As Long, vDuration As Long, vDays As Long, vAppts As Long, vApptID As Long
Dim vNewStart As Date, vNewEnd As Date, vTime As Date

vMax = Mid(vPattern, 35, 3) 'fetch number of appts to create from pattern string
vNewStart = Mid(vPattern, 1, 10) 'and fetch Start Date
vTime = Mid(vPattern, 12, 5) 'fetch Start Time
vDuration = Mid(vPattern, 29, 5) 'and duration (in minutes)
If vDuration < 1440 Then 'if appt duration is less than 1 day then
If Me.chkAllDay = True Then 'if also All Day Event then
vNewStart = Mid(vPattern, 1, 10) 'and fetch Start Date
vNewEnd = vNewStart + TimeValue(conLastTime) 'add LastTime to End Date
vNewEnd = DateAdd("n", conPeriod, vNewEnd) 'and add appt period in conPeriod
vNewStart = vNewStart + TimeValue(conFirstTime) 'add start time to start date
Else
vNewStart = vNewStart + vTime 'add start time to start date
vNewEnd = DateAdd("n", vDuration, vNewStart) 'add duration to vNewStart to get End Date/time
End If
Else 'if appt duration is 1 day or longer then
Me.chkAllDay = True 'and set All day mode
vNewStart = vNewStart + TimeValue(conFirstTime) 'add conFirstTime to start date
vNewEnd = DateAdd("n", vDuration, vNewStart) 'add duration to vNewStart to get End Date/time
vNewEnd = DateValue(vNewEnd) + TimeValue(conLastTime) 'set End Time to conLastTime
vNewEnd = DateAdd("n", conPeriod, vNewEnd) 'and add appt period in conPeriod
vNewEnd = vNewEnd - 1 'subtract 1 day
End If

vAppts = 0 'zero appt counter
For vCount = 1 To vMax 'for each recurring appt
If vMode = False Then 'if in Check mode then
If conMultiAppts = 1 Then 'if multiple appts for a time slot is NOT allowed then
vApptID = AppointmentsCheck(vNewStart, vNewEnd, 0, vRecurrenceID, vCategoryID) 'fetch ID of overlapped appt (if any)
If vApptID > 0 Then vAppts = vAppts + 1 'inc appt counter
End If
Else 'if in Insert mode then
CurrentDb.Execute "INSERT INTO tblAppointments (ApptSubject, ApptLocation, ApptStart, ApptEnd, AllDayEvent, ApptNotes, RecurrenceID, Pattern, CategoryID) VALUES (" _
& QUOTE & Me.txtSubject & QUOTE & ", " _
& QUOTE & Me.txtLocation & QUOTE & ", " _
& Format(vNewStart, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& Format(vNewEnd, "\#mm\/dd\/yyyy hh\:nn\#") & ", " _
& IIf(Me.chkAllDay = True, -1, 0) & ", " _
& QUOTE & Me.txtNotes & QUOTE & ", " _
& vRecurrenceID & ", " _
& "'" & vPattern & "', " _
& vCategoryID & ")" 'and insert new record into tblAppointments
End If
vDays = CalcNextDate(DateValue(vNewStart), vPattern) 'fetch No of days until next date
vNewStart = vNewStart + vDays 'add days count to start date
vNewEnd = vNewEnd + vDays 'and end date
Next
InsertRecurringAppts = vAppts 'return overlapping appt count

End Function

Public Sub RecurringMode()

'Activate/Deactivate Recurring mode
'Entry (Me.txtPattern) = holds recurrence pattern or NULL
' (Me.chkRecurSingle) = False (Single pattern) or = True (Series Appt)

Dim vDuration As Long

If Nz(Me.txtPattern) = "" Or Nz(Me.txtPattern) = "X" Then 'if Pattern = '' or 'X' then
Me.txtStartDate.Visible = True
Me.cboStartTime.Visible = True
Me.txtEndDate.Visible = True
Me.cboEndTime.Visible = True
Me.chkAllDay.Visible = True
Else
If Me.chkRecurSingle = True Then
Me.txtStartDate.Visible = False
Me.cboStartTime.Visible = False
Me.txtEndDate.Visible = False
Me.cboEndTime.Visible = False
Else
Me.txtStartDate.Visible = True
Me.cboStartTime.Visible = True
Me.txtEndDate.Visible = True
Me.cboEndTime.Visible = True
End If
End If

If Nz(Me.txtPattern) = "" Or Nz(Me.txtPattern) = "X" Then 'if Pattern = '' or 'X' then
Me.Label34.Visible = False 'hide recurrence info
Else
Me.Label34.Visible = True 'show recurrence info
Me.Label34.Caption = "Recurrence: " & SetRecurringCaption(Me.txtPattern) 'display recurring pattern on form
vDuration = Mid(Me.txtPattern, 29, 5) 'fetch duration (in minutes)
If vDuration < 1440 Or Me.chkRecurSingle = False Then Me.chkAllDay.Visible = True Else Me.chkAllDay.Visible = False 'if appt duration is less than 1 day then display All day Event box
End If

If Me.chkAllDay = True Then 'if All Day Event then
Me.cboStartTime.Visible = False 'hide Time combos
Me.cboEndTime.Visible = False
End If

End Sub

Public Sub ClearControls()

'clear main controls

Me.txtAppointmentID = 0 'reset AppointmentID
Me.lstAppts = Null 'clear any selections in list box
Me.txtSubject = ""
Me.txtLocation = ""
Me.txtNotes = ""
Me.txtPattern = ""
Me.cmddelete.Enabled = False
Me.cmdSave.Enabled = False
Me.cmdRecur.Enabled = True
Me.chkSave = False 'reset Save flag if starting new appt
Me.chkAllDay = False
Me.chkRecurSingle = False
RecurringMode 'disable recurring mode

End Sub



Go to the top of the page
 
Peter Hibbs
post Mar 16 2019, 04:00 AM
Post#163


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi basehumax,

Well, that does not really help as I wrote all that code anyway.

Did you check the 'QUOTE' declarations in the VBA modules as I suggested?

I think the best option is for you to upload your (zipped) database here so I can have a look at it.

Peter.
Go to the top of the page
 
basehumax
post Mar 16 2019, 11:02 AM
Post#164



Posts: 40
Joined: 17-June 18



hi peter

can you please tell easy way to check duplicate via modules thanks
my file is very big i need to strip if i have to upload let know if something i can do myself to lookup cheers
Go to the top of the page
 
basehumax
post Mar 16 2019, 01:53 PM
Post#165



Posts: 40
Joined: 17-June 18



Hi Peter

Thank you so much got now and is working i really appreciated your help mate
Go to the top of the page
 
Peter Hibbs
post Mar 16 2019, 04:18 PM
Post#166


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi,

yw.gif

Peter.
Go to the top of the page
 
basehumax
post Mar 16 2019, 09:10 PM
Post#167



Posts: 40
Joined: 17-June 18



Hi Peter,

i am getting strange error when click on day the calendar but everything else works fine?
Attached File(s)
Attached File  2019_03_16_LI.jpg ( 466.61K )Number of downloads: 5
 
Go to the top of the page
 
Peter Hibbs
post Mar 17 2019, 04:43 AM
Post#168


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi basehumax,

I don't know but my guess is that you have an appointment record that has a double quote character in the Subject field. Perhaps you could check that for the date that the error appears on and if so, I suggest you replace the double quote character with two single quotes which look the same to the user but will not generate an error. If that is not the problem then you will need to supply more details of the problem.

Peter.
Go to the top of the page
 
basehumax
post Mar 17 2019, 10:22 AM
Post#169



Posts: 40
Joined: 17-June 18



Hi Peter

is only when click day view from the calendar, when you get the error also you can create appointment from day view but will not show that appointment on day view screen but will show other views like month or year i checked "" but i dont have any appointment set up at all do you know what it can be?
Go to the top of the page
 
Peter Hibbs
post Mar 17 2019, 11:27 AM
Post#170


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi basehumax,

Hmmm, very odd!

Have you made any changes to the version that you downloaded (I don't have any problems with my original copy)?

I think the first thing to try is to open the VBA Module modCalendarCode, scroll down to the Public Sub ShowDayAppts(vDate As Date, vCategoryID As String) routine and REM out this line On Error GoTo ErrorCode at the top of the routine. Then open the Daily calendar again and when it errors out, it should stop on the line of code that is causing the problem. This might give a clue to what is happening (or it might not) but either way, perhaps you could show us a screen shot of the code window when it does.

If that does not show up anything useful then maybe you could upload a copy of the database so we can have a closer look.

Peter.
Go to the top of the page
 
basehumax
post Mar 17 2019, 01:30 PM
Post#171



Posts: 40
Joined: 17-June 18



Hi Peter

bit strange i know this error comes on when click day from the calendar main but if i open the file direct frmCalendarDay no error.
i have taken off Error GoTo ErrorCode but the error was still showing up, see screenshots please thanks
This post has been edited by basehumax: Mar 17 2019, 01:31 PM
Attached File(s)
Attached File  2019_03_17__2_.png ( 18.57K )Number of downloads: 7
Attached File  2019_03_17__2_.png ( 18.57K )Number of downloads: 5
Attached File  2019_03_16.png ( 30.44K )Number of downloads: 7
 
Go to the top of the page
 
Peter Hibbs
post Mar 17 2019, 02:57 PM
Post#172


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi basehumax,

It is not possible to say what the problem is just from screen shots so all I can suggest is that you upload a copy of the database so that I can have a look. I am also wondering if you have made some changes to the code that has caused this problem. It looks like you have made some changes so perhaps you need to single step through the code when you click the Daily Mode button to see what happens.

Peter.
Go to the top of the page
 
cmohanc
post Mar 18 2019, 10:58 AM
Post#173



Posts: 60
Joined: 8-May 16



Thank Yoy!
Go to the top of the page
 
basehumax
post Mar 18 2019, 06:09 PM
Post#174



Posts: 40
Joined: 17-June 18



Hi Peter

Its Strange i have just rib Calendar code the module and paste again and now it works no more error thanks Peter
Go to the top of the page
 
Peter Hibbs
post Mar 19 2019, 12:16 PM
Post#175


UtterAccess VIP
Posts: 1,658
Joined: 17-June 10
From: Dorset. UK.


Hi basehumax,

OK, excellent (these things happen sometimes) and good luck with the project.

Peter.
Go to the top of the page
 
basehumax
post Mar 19 2019, 08:30 PM
Post#176



Posts: 40
Joined: 17-June 18



cheers peter
Go to the top of the page
 
9 Pages V « < 7 8 9


Custom Search


RSSSearch   Top   Lo-Fi    25th March 2019 - 05:43 PM