Change daily calendar entry color depending on Business/Personal Flag in Microsoft Access

I needed to build a database around an appointment scheduler but, since I am just a hacker, I was not successful at building my own calendar.  I found a basic calendar database from another site (credit:  http://www.utteraccess.com/forum/Updated-Appointment-Calen-t1634292.html&hl=calendar).  It's a very nice calendar interface and works great.  However, I am trying to make an improvement to it that I just cannot figure out how to do.

In the daily calendar view form it calls the attached Public Sub code on the "Form Open" event that builds the days appointments and places them in the correct time slots.  Upon doing this, it adds lines, arrows, and coloring to the text boxes to the left of the appointment, coloring them in a shade of blue to show the time is "Busy".

I have added a flag in the tblAppointments table that accounts for whether an appointment entry is "business" or "personal".  I would like the Daily Calendar view to have different color shading depending on which type of appointment it is.  (i.e. blue for business and yellow for personal).

I've tried several of my own ideas to modify the code to account for this change, but have been unsuccessful in getting it to work.  Obviously, I don't really understand how the code is working.  So, I am asking if someone will educate me and give me some idea of how to modify the code to do this for me?  I appreciate any help and suggestions.  Thank you.

'   This sub fills in the appointments on the daily calendar.

Public Sub DisplayDailyMeetings()
    
    Dim strSQL As String
    Dim i As Integer
    Dim r As Integer
    Dim intTemp As Integer
    Dim intLength(30) As Integer
    Dim strHours(30) As String
    Dim strApptSubject As String
    Dim strApptStartTime As String
    Dim strApptEndTime As String
    Dim rst
        
'   Clear all appointments and shading
    For r = 1 To 29
        Me("txtShade" & Trim(r)) = ""
        Me("txtShade" & Trim(r)).BackColor = 16777215
        Me("txt" & Trim(r)) = ""
        strHours(r) = ""
    Next r

'   Update the active date in the form header
    Me.lblDate.Caption = Format(dtePubMyDate, "Long Date")

'   Get the appointments for the active date
    strSQL = "SELECT tblAppointments.*, tblOffHours.HourID " & _
             "FROM tblAppointments INNER JOIN tblOffHours " & _
             "ON tblAppointments.ApptStartTime = tblOffHours.Hours " & _
             "WHERE tblAppointments.ApptDate = #" & dtePubMyDate & "# " & _
             "ORDER BY ApptStartTime;"
       
    Set rst = CurrentDb.OpenRecordset(strSQL)
    
'   If there are appointments for the active date...
    If rst.RecordCount > 0 Then
    
'       Loop through the active date's appointments and assign
'       the subject/length of appointment to the right arrays
        b = 1
        rst.MoveFirst
        Do While Not rst.EOF
            strApptStartTime = rst!ApptStartTime
            strApptEndTime = rst!ApptEndTime
            strApptSubject = rst!Appt
            intTemp = rst!HourID

            If (intTemp > 100) Then
                
                intTemp = intTemp - 100
                strApptSubject = strApptSubject & " (" & Format(strApptStartTime, "hh:mm AM/PM") & " - " & Format(strApptEndTime, "hh:mm AM/PM") & ")"
            End If

'           assign the subject to the array
            If Not IsNull(strApptSubject) Then
                strHours(intTemp) = strApptSubject
                
'               Calculate minutes, then divide by 30 to get half hour increments
                intLength(intTemp) = Abs(DateDiff("n", strApptEndTime, strApptStartTime)) / 30
            End If
            rst.MoveNext
        Loop
    
'       Loop through the textboxes and fill in the appointments and
'       shade the times that the appointment takes up.  Also, add arrows.
        For r = 1 To 29
            
'           Meeting subject
            Me("txt" & Trim(r)) = strHours(r)
                
'           If the time box is shaded or free, skip it
            If (Me("txt" & Trim(r)).Value) = "" And (Me("txtShade" & Trim(r)).Value) = "" Then
                Me("txtShade" & Trim(r)).BackColor = 16777215
            ElseIf (Me("txt" & Trim(r)).Value) = "" And (Me("txtShade" & Trim(r)).Value) <> "" Then
'               Do nothing
            Else
'               Shade in the time slots and put in the arrow markers (Symbol font)

                    Me("txtShade" & Trim(r)).BackColor = 16764057
'               Up Arrow (beginning of meeting)
                Me("txtShade" & Trim(r)).Value = Chr(173)
                
                For i = 1 To (intLength(r) - 2)
                
                    Me("txtShade" & Trim(r + i)).BackColor = 16764057
'                   Vertical line (Middle of long meeting)
                    Me("txtShade" & Trim(r + i)).Value = Chr(189)
                Next i
                
                    Me("txtShade" & Trim(r + intLength(r) - 1)).BackColor = 16764057
'               Down Arrow (End of meeting)
                Me("txtShade" & Trim(r + intLength(r) - 1)).Value = Chr(175)
            End If
        Next r
    End If
    
    rst.Close

End Sub

Open in new window

JohnMc0620Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Jeffrey CoachmanMIS LiasonCommented:
First I will say that, if it were me, I would use Outlook for managing Appointments.
You can create you own custom "Categories" ( Business, Personal) and assign a color.

Done,
...no 100 lines of code needed...
;-)

There are many other features in Outlook that would be hard to replicate in Access.

I am not familiar with the Calendar code you posted there, nor can I be sure of your modifications thereof.

But in a very broad sense you can use conditional formatting in Access to set colors based on the value of a field. (works faster than a code based approach and will work flawlessly in reports as well)
screen
Here is an example

JeffCoachman
Database142.mdb
0
JohnMc0620Author Commented:
Jeff,

Thanks for your comment.  And... I know... I wish I could avoid the code!  The very reason I am using Access instead of Outlook is that this project is a database... not a calendar.  In addition to storing the appointment information, there is so much more data that I have to capture at the time of (and after) an appointment, as well as other features and reports I have to have the computer handle for me to simplify the data capture and allow me to do my job.  The core of all this data revolves around the appointment itself, but ranges in to things like income, expenses, professional notes, data transfers, documentation, etc.  Outlook simply cannot handle all of this.  And, the database needs the appointment info to track everything else.

I looked at the sample you gave me.  It seems that conditional formatting relies on a standardized report or form where it is a listing of line item record data over and over.  The form I am using is not set up that way, more like many text boxes that the code systematically fills in as each record is examined in the loop, and I am trying to avoid having to reinvent the wheel.  Like I said, it does everything else I need.  I just want to be able to change the colors and am hoping someone can give me that one suggestion on how to improve the code for that purpose.

I appreciate the information!  Thank you!
0
Jeffrey CoachmanMIS LiasonCommented:
<many text boxes that the code systematically fills in as each record is examined in the loop>
...?

Again, without seeing this db in action it is difficult to see what the sticking point is...

If all you need to do is set the color based on a value, something like this should work:

If me.txtCategory="Business" Then
   Me.txtCategory.BackColor=vbred
elseIf me.txtCategory="Personal" Then
    me.Category.backColor=vbBlue
end if

Try something like this first and let me know.

If not, then you may have to post a sample of this db with explicit instructions for its use.

JeffCoachman
0
10 Tips to Protect Your Business from Ransomware

Did you know that ransomware is the most widespread, destructive malware in the world today? It accounts for 39% of all security breaches, with ransomware gangsters projected to make $11.5B in profits from online extortion by 2019.

JohnMc0620Author Commented:
I tried this.  I couldn't get it to work because it looks like the code is looping through the appointments in the table and holding on to just the appts for that particular day and storing them in some kind of a memory array.  From there, it looks like it loops through a second time and colors the boxes associated with the appointments.  I am not sure how the first and second loops are connected and how it figures out which should be blue.

I've uploaded the .zip file I got from the link above.  I am using the "ApptCalendar2003" file.  Add an appointment, then go to the Daily Calendar form for that day.  You will see how it colors and populates the text boxes beside the appointment entry.  I want to control what color these boxes are made depending on my business/personal flag.

Thanks again!
Updated-Appointment-Calendar.zip
0
Jeffrey CoachmanMIS LiasonCommented:
oK,
I huffed and puffed, but I could not find a way to do this...
I was going to suggest using the rich text feature in the .accdb format, but this will display the HTLM codes in the calendar.

It looks like there are just concatenating each new meeting into the Day textbox, so I can't see a way to "color" one appointment any other color from what they all are (whatever the backcolor of the textbox is)

What you can do is detect if i certain value is "In" in the day textbox , then turn the entire day a different color
for example on the open event of the big form do something like this:
    If InStr(Me.Day17, "Personal") Then
        Me.Day17.BackColor = vbRed
    Else
        Me.Day17.BackColor = vbWhite
    End If
...obviously you would have to loop this for all the day textboxes...
Not sure if that helps, but that is all I can see right now.

BTW, I don't see anywhere you can specify the "Status  flag" for business or personal, ...so if this is just a sample db you posted, you will have to adjust my code as needed.

JeffCoachman
0
Jeffrey CoachmanMIS LiasonCommented:
Have you tried contacting the author of this calendar system?
0
JohnMc0620Author Commented:
Thanks Jeff!  I really appreciate the help!  I have reached out to this person via another message board, but have not received any response yet.  The post was from 2008, so I can't even say if that person is on the board at all any more or not.

Sorry, I did post the generic version of the DB that came directly from the other post.  So, there was no added field for the Business/Personal flag.  I figured it was easy enough to add if you were testing.  Everything else about the calendar is basically the same as the original.  It's just that my copy has a lot of other "stuff" in it now not pertaining to these forms or code for this question.

I'll give your idea a try.  And, I'm also brewing another idea of my own.  Might be a lot of work, but I am hoping it might get me exactly what I am looking for.  Will probably take a day or two to get everything tried out.  Will get back and let you know how it went.

Thank you very much for your time!
0
Jeffrey CoachmanMIS LiasonCommented:
Yes, if you want to get crazy, I guess you could create multiple textboxes and move them tightly together to form one "day"
Then you could format them separately...
0
JohnMc0620Author Commented:
Ok... So I got it to work.  Here's what I did...

I figured out that the first Do While Loop was checking each entry in tblAppointments and storing the necessary information in the intTemp array.  The variable "strHours(intTemp)" is storing the subject and connecting it to a time slot (i.e. 08:30 AM).  

So what I did here was to create two new variables called strApptBiz and strBiz(30), both as Strings.   The first is used in the Loop to determine if the table flag for Business is true (strApptBiz = 1) or false (strApptBiz = 2).  Then, at the end of the Loop it assigns this value to the corresponding line in the array with strBiz(30) = strApptBiz.  This gives me an independently set variable for business/personal for each appointment in the array.

I figured out that the "For r = 1 To 29" Loop at the bottom of the code was where the code carried the variables and associated them with the text box for the corresponding time line.  All I needed to do was use my Biz Flag, strBiz(r), here to tell it to use one color or the other.

Under the section declared as "Shade in the time slots and put in the arrow markers (Symbol font)", I added several If-Then statements to determine whether strBiz(r) is marked as a 1 or 2 for this entry.  Depending on the value, it uses a different color for the associated boxes.

It worked so well, I then did the same process to deal with appointments that are scheduled on the quarter hour, since this calendar only shows 1/2 hour increments.  Success!

Here is the finished Sub:

'   This sub fills in the appointments on the daily calendar.

Public Sub DisplayDailyMeetings()
    
    Dim strSQL As String
    Dim i As Integer
    Dim r As Integer
    Dim intTemp As Integer
    Dim intLength(30) As Integer
    Dim strHours(30) As String
    Dim strBiz(30) As String
    Dim strOHours(30) As String
    Dim strApptSubject As String
    Dim strApptBiz As String
    Dim strApptOHours As String
    Dim strApptStartTime As String
    Dim strApptEndTime As String
    Dim rst
        
'   Clear all appointments and shading
    For r = 1 To 29
        Me("txtShade" & Trim(r)) = ""
        Me("txtShade" & Trim(r)).BackColor = 16777215
        Me("txt" & Trim(r)) = ""
        Me("OTim" & Trim(r)) = Null
        Me("Biz" & Trim(r)) = Null
        strHours(r) = ""
        strBiz(r) = ""
        strOHours(r) = ""
    Next r

'   Update the active date in the form header
    Me.lblDate.Caption = Format(dtePubMyDate, "Long Date")

'   Get the appointments for the active date
    strSQL = "SELECT tblAppointments.*, tblOffHours.HourID " & _
             "FROM tblAppointments INNER JOIN tblOffHours " & _
             "ON tblAppointments.ApptStartTime = tblOffHours.Hours " & _
             "WHERE tblAppointments.ApptDate = #" & dtePubMyDate & "# " & _
             "ORDER BY ApptStartTime;"
       
    Set rst = CurrentDb.OpenRecordset(strSQL)
    
'   If there are appointments for the active date...
    If rst.RecordCount > 0 Then
    
'       Loop through the active date's appointments and assign
'       the subject/length of appointment to the right arrays
        rst.MoveFirst
        Do While Not rst.EOF
            strApptStartTime = rst!ApptStartTime
            strApptEndTime = rst!ApptEndTime
            strApptSubject = rst!Appt
            
            If rst!Business = True Then
                strApptBiz = 1
            Else
                strApptBiz = 2
            End If
            
            intTemp = rst!HourID

            If (intTemp > 100) Then
                
                strApptOHours = 1
                intTemp = intTemp - 100
                strApptSubject = strApptSubject & " (" & Format(strApptStartTime, "hh:mm AM/PM") & " - " & Format(strApptEndTime, "hh:mm AM/PM") & ")"
            End If

'           assign the subject to the array
            If Not IsNull(strApptSubject) Then
                strHours(intTemp) = strApptSubject
                strBiz(intTemp) = strApptBiz
                strOHours(intTemp) = strApptOHours
                
'               Calculate minutes, then divide by 30 to get half hour increments
                intLength(intTemp) = Abs(DateDiff("n", strApptEndTime, strApptStartTime)) / 30
            End If
            rst.MoveNext
        Loop
    
'       Loop through the textboxes and fill in the appointments and
'       shade the times that the appointment takes up.  Also, add arrows.
        For r = 1 To 29
            
'           Meeting subject
            Me("txt" & Trim(r)) = strHours(r)
            Me("Biz" & Trim(r)) = strBiz(r)
            Me("OTim" & Trim(r)) = strOHours(r)
                
'           If the time box is shaded or free, skip it
            If (Me("txt" & Trim(r)).value) = "" And (Me("txtShade" & Trim(r)).value) = "" Then
                Me("txtShade" & Trim(r)).BackColor = 16777215
            ElseIf (Me("txt" & Trim(r)).value) = "" And (Me("txtShade" & Trim(r)).value) <> "" Then
'               Do nothing
            Else
'               Shade in the time slots and put in the arrow markers (Symbol font)

                    If (strBiz(r) = 1) Then
                        Me("txtShade" & Trim(r)).BackColor = 16764057
                    End If

                    If (strBiz(r) = 2) Then
                        Me("txtShade" & Trim(r)).BackColor = 9170175
                    End If
'               Up Arrow (beginning of meeting)
                Me("txtShade" & Trim(r)).value = Chr(173)
                
                For i = 1 To (intLength(r) - 2)
                
                    If (strBiz(r) = 1) Then
                        Me("txtShade" & Trim(r + i)).BackColor = 16764057
                    End If

                    If (strBiz(r) = 2) Then
                        Me("txtShade" & Trim(r + i)).BackColor = 9170175
                    End If
'                   Vertical line (Middle of long meeting)
                    Me("txtShade" & Trim(r + i)).value = Chr(189)
                Next i

                    If (strBiz(r) = 1) Then
                        Me("txtShade" & Trim(r + intLength(r) - 1)).BackColor = 16764057
                    End If

                    If (strBiz(r) = 2) Then
                        Me("txtShade" & Trim(r + intLength(r) - 1)).BackColor = 9170175
                    End If
'               Down Arrow (End of meeting)
                Me("txtShade" & Trim(r + intLength(r) - 1)).value = Chr(175)
            End If
        Next r
    End If
    
    rst.Close

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Jeffrey CoachmanMIS LiasonCommented:
Great work!

You may want to bring this to the attention of the author of this system...
;-)

JeffCoachman
0
JohnMc0620Author Commented:
I hashed out the code on my own.  Explanation and code have been posted for solution to original question.
0
Jeffrey CoachmanMIS LiasonCommented:
Again, congratulation on the great work here.

(Soon you won't need us anymore...)
;-)

Jeff
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.