Help with VBA! (1 Viewer)

[mdwalters]

Hello. Brand new member. First time posting, although I have taken many useful hints and tips from the forum in the past before joining.

I am now asking (begging) for some help.

I have a form, which contains 42 textboxes to create a calendar layout. The code works fine for displaying the calendar and includes the city name in the correct boxes. I have adapted the code from a post I found online...but now I have some superfluous lines of code that refer to tables I don't intend to use. However, if I remove the code or delete the tables I am not using then I get an error message. I could, theoretically, leave the database as it is and ignore the below lines and the tables that associate with them...but it irritates me and I would appreciate any help in getting rid of the lines and the associated tables.

Here is the code(the lines I want to remove are in red):

Option Explicit

Private intMonth As Integer
Private intYear As Integer
Private lngFirstDayOfMonth As Long
Private intFirstWeekday As Integer
Private intDaysInMonth As Integer
Private myArray() As Variant

Private Sub Form_Load()
With Me
    .cboMonth = Month(Date)
    .cboYear = Year(Date)
End With

Call Main

End Sub


Private Sub cboMonth_AfterUpdate()
On Error GoTo ErrorHandler

Call Main

ExitSub:
    Exit Sub

ErrorHandler:
    MsgBox "There has been an error. Please reload the form"
    Resume ExitSub

End Sub


Private Sub cboYear_AfterUpdate()
On Error GoTo ErrorHandler

Call Main

ExitSub:
    Exit Sub

ErrorHandler:
    MsgBox "There has been an error. Please reload the form"
    Resume ExitSub
End Sub

Private Sub Main()
On Error GoTo ErrorHandler

Call InitVariables
Call InitArray
Call LoadArray
Call PrintArray



ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "There has been an error. Please reload the form"
    Resume ExitSub
End Sub

Private Sub InitVariables()
On Error GoTo ErrorHandler

intMonth = Me.cboMonth
intYear = Me.cboYear
lngFirstDayOfMonth = CLng(DateSerial(intYear, intMonth, 1))
intFirstWeekday = getFirstWeekday(lngFirstDayOfMonth)
intDaysInMonth = getDaysInMonth(intMonth, intYear)

ExitSub:
    Exit Sub

ErrorHandler:
    MsgBox "There has been an error. Please reload the form"
    Resume ExitSub
End Sub


Private Sub InitArray()
Dim i As Integer

ReDim myArray(0 To 41, 0 To 2)

For i = 0 To 41

    myArray(i, 0) = lngFirstDayOfMonth - intFirstWeekday + 1 + i
    If Month(myArray(i, 0)) = intMonth Then
        myArray(i, 1) = True
        myArray(i, 2) = Day(myArray(i, 0))
    Else
        myArray(i, 1) = False
    
    End If
Next i

End Sub

Private Sub LoadArray()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Dim strSQL As String
Dim i As Integer

strSQL = "SELECT tblExam.ExamID, tblExam.ExamDate, tblExam.City, " _
    & "tblExam.City AS Part1 " _
    [COLOR="Red"]& "FROM tblLocations INNER JOIN ((tblCourse INNER JOIN tblLevel ON tblCourse.Level = tblLevel.LevelID) " _
    & "INNER JOIN (tblExam INNER JOIN tblTeachers ON tblExam.TeacherID = tblTeachers.TeacherID) " _
    & "ON tblCourse.CourseID = tblExam.CourseID) ON tblLocations.LocationID = tblExam.LocationID " _[/COLOR]
    & "ORDER BY tblExam.ExamDate;"
    

Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
    
    If Not rs.BOF And Not rs.EOF Then
        
        For i = LBound(myArray) To UBound(myArray)
            
            If myArray(i, 1) Then
                rs.Filter = "[ExamDate]=" & myArray(i, 0)
                
                Set rsFiltered = rs.OpenRecordset
                
                Do While (Not rsFiltered.EOF)
                    
                    myArray(i, 2) = myArray(i, 2) & vbNewLine _
                    & rsFiltered!Part1
                    
                    rsFiltered.MoveNext
                Loop
            
            End If
        Next i
        
    End If
    
    rsFiltered.Close
    rs.Close

Set rsFiltered = Nothing
Set rs = Nothing
Set db = Nothing


End Sub

Private Sub PrintArray()
On Error GoTo ErrorHandler

Dim strCtlName As String
Dim i As Integer

For i = LBound(myArray) To UBound(myArray)
    strCtlName = "txt" & CStr(i + 1)
    Controls(strCtlName).Tag = i
    Controls(strCtlName) = ""
    Controls(strCtlName) = myArray(i, 2)
Next i


ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "There has been an error. Please reload the form"
    Resume ExitSub

End Sub

 

[JHB]

I suppose you'll keep table tblExam?:

strSQL = "SELECT ExamID, ExamDate, City AS Part1 " _
& "FROM tblExam ORDER BY ExamDate"

 

[arnelgp]

comment out all the sub (sub LoadArray). also in Main sub, comment out Call LoadArray.
the city that you are seeing comes from the above sub.

 

[isladogs]

If you just want code to create your own date picker /calendar form, have a look at this: https://www.access-programmers.co.uk/forums/showthread.php?t=298062

 

[Uncle Gizmo]

I also have my own datepicker the "Nifty Date Picker"

I provide the Code and demonstrate how you can build it yourself with a YouTube video on my website here:-

https://www.niftyaccess.com/nifty-date-picker/

Alternatively there's a ready-made ready to go version that can be had for the price of a cup of coffee!

In your case you may prefer the "build it yourself" version with instructions, as you will be able to mould it to have the look and features you require.

Sent from my Pixel 3a using Tapatalk

 

[mdwalters]

JHB - thank you. That worked perfectly. Seems so simple now but I just couldn’t see it myself.

 

[mdwalters]

Now that I have gotten rid of the superfluous code I have a follow up question.

I would like the font colour to change depending on the City. I have tried using [City].ForeColor but must be doing something wrong. For example, if the exam is in London the word ‘London’ on the Calendar array would appear in Green. If it is in birmingham it would appear in Red. I think my problem is when two cities are on the same date I want them to appear in different colours, but I can’t seem to have two colours in 1 text box.

Can anyone help with the code I need and where it should appear in the Load Array Sub?

 

[arnelgp]

use conditional formatting on the textbox.
choose Expression Is

[City]="London" (choose green background)

another formatting

[city]="Birmingham" (choose red)

 

[mdwalters]

Thanks but I have already tried conditional formatting. I am not sure if it because of the way the LoadArray works but putting conditional formatting on the textbox does not work. The issue as well is I need to be able to have multiple different text colours in the same textbox where there are exams in more than one city on the same date.

 

[MajP]

The issue as well is I need to be able to have multiple different text colours in the same textbox where there are exams in more than one city on the same date.

You can conditionally format multiple words in a textbox, but you have to set the text format to rich text, andstore the tags for that word in a table. Something like

SearchWord	CodeTag
London	<font color=white style='BACKGROUND-COLOR:#000000'>
Birmingham	<font color=black style='BACKGROUND-COLOR:#FFFF00'>
Detroit	<font color=black style='BACKGROUND-COLOR:#FFA500'>
New York	<font color=black style='BACKGROUND-COLOR:#CDBA96'>

Then you need to find the word and replace with the word and the tags.

Public Function ConvertString(strIn As String) As String
  Dim rs As DAO.Recordset
  Dim CodeTag As String
  Dim SearchWord As String
  Set rs = CurrentDb.OpenRecordset("tblRT_Codes")
 
  Do While Not rs.EOF
    CodeTag = rs!CodeTag
    SearchWord = rs!SearchWord
    If InStr(strIn, SearchWord) > 0 Then
      strIn = Replace(strIn, SearchWord, CodeTag & SearchWord & "</font>")
    End If
    rs.MoveNext
 Loop
 
  ConvertString = strIn
End Function

Then make the control calculated something like

=ConvertString([SomeField

])

 

[MajP]

Looking at your code that you adopted, it looks like some of the code I wrote years ago for a yearview I made for screen name Oxicotin. If you have that db, it uses this concept to get multi colors in a textbox for a date.

 

[mdwalters]

Hi MajP

Sadly the code was not adapted from your previous code. What you have demonstrated in your posts above is exactly what I want to do. However, I am unclear where I would insert the code you have written into my existing code to make it happen.

 

[MajP]

In your code

 myArray(i, 2) = myArray(i, 2) & vbNewLine _
                    & rsFiltered!Part1

would be modified to

 myArray(i, 2) = myArray(i, 2) & vbNewLine _
                    & convertString(rsFiltered!Part1)

Ensure that each of the textboxes that you put this value is set
Text Format: Rich Text

Public Function ConvertString(strIn As String) As String
  Dim rs As DAO.Recordset
  Dim CodeTag As String
  Dim SearchWord As String
  Set rs = CurrentDb.OpenRecordset("tblRT_Codes")
 
  Do While Not rs.EOF
    CodeTag = rs!CodeTag
    SearchWord = rs!SearchWord
    If InStr(strIn, SearchWord) > 0 Then
      strIn = Replace(strIn, SearchWord, "<br>" & CodeTag & SearchWord & "</font>")
    End If
    rs.MoveNext
 Loop
 
  ConvertString = strIn
End Function

you will have to get the correct tags and store in table. If is just the backcolor copy the string and replace the HEX value of the color.

Based on the code naming and naming conventions, some of the code was likely adopted from something I posted on line.

Example

lngFirstDayOfMonth = CLng(DateSerial(intYear, intMonth, 1))
intFirstWeekday = getFirstWeekday(lngFirstDayOfMonth)
intDaysInMonth = getDaysInMonth(intMonth, intYear)

Here are my functions with the exact naming convention and format

Public Function getFirstOfMonth(intYear As Integer, IntMonth As Integer) As Date
    getFirstOfMonth = DateSerial(intYear, IntMonth, 1)
End Function

Public Function getDaysInMonth(FirstDayOfMonth As Date) As Integer
    getDaysInMonth = Day(DateAdd("m", 1, FirstDayOfMonth) - 1)   'Days in month.
End Function

 

[mdwalters]

Thanks for the help. I will try to implement what you have suggested and will report back with my results.

It does seem likely that i came across your code then. Either directly or second hand from someone else who benefited from your wisdom.

 

[mdwalters]

Worked like a charm. You are a star. Thank you!

 

[MajP]

It does seem likely that i came across your code then. Either directly or second hand from someone else who benefited from your wisdom.

I probably have posted 100 of thousands of lines of code on different forums. Often I will come across code in a thread and I usually can tell by the "signature" something I would have wrote.

Here is the link to the db on this site
https://www.access-programmers.co.uk/forums/showpost.php?p=1342710&postcount=69

You can demo this (go to 2014)