html_calendar_s4p_170815_accdb

Option Compare Database
Option Explicit

Private Sub cmd_Close_Click()
  '151204 strive4peace
   DoCmd.Close acForm, Me.Name
End Sub

Private Sub cmd_GoToYouTube_Click()
   Application.FollowHyperlink _
      "https://www.youtube.com/LearnAccessByCrystal"
End Sub

Private Sub cmd_vid1_Click()
  '1509 strive4peace
   On Error Resume Next
   Me.WebBrowserVideo.Navigate "https://www.youtube.com/v/pgPiUE-AfaA" _
      & "&hl=en" _
      & "&fs=1" _
      & "&ap=%2526fmt%3D22" _
      & "&showsearch=0" _
      & "&rel=0"
End Sub

Private Sub Form_Load()
   Call cmd_vid1_Click
End Sub

Private Sub cmd_visit_Click()
   On Error Resume Next
   Application.FollowHyperlink _
      "http://www.MsAccessGurus.com/freetips.html"
End Sub

Option Compare Database
Option Explicit
  ' Strive for Peace and Understanding
  '============================================================ LICENSE NOTICE -- must not be modified
  ' This software is licensed to you under CC BY-NC-SA 3.0
  '               Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported
  ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/
  '
  ' You are free to:
  '    Share — copy and redistribute the material in any medium or format
  '    Adapt — remix, transform, and build upon the material
  ' The licensor cannot revoke these freedoms as long as you follow these terms:
  '    Attribution — You must give appropriate credit, provide a link to the license,
  '                   and indicate if changes were made.
  '                   You may do so in any reasonable manner,
  '                   but not in any way that suggests the licensor endorses you or your use.
  '    NonCommercial — You may not use the material for commercial purposes.
  '    ShareAlike — If you remix, transform, or build upon the material,
  '                 you must distribute your contributions under the same license as the original.
  '
  ' many procedures and module names contain author or controbitor names that must be left intact
  ' if you make changes, add your name, date, and descriptive information to the comments
  '
  ' thank you for sharing in the Access community ~ crystal, strive4peace, 170727
  ' ~ crystal
  '              * have an awesome day :)
  '                                                   www.msAccessGurus.com
  ' END LICENSE NOTICE
  '============================================================
  'mod_HtmlCalendarReport_s4p
  '
Dim mStartTime As Date

Dim masColor(1 To 2, 1 To 3) As String

Private Sub SetTheColors()
  '170719 s4p
     ' this could be modified to take parameters for the colors
     ' there are 3 possible pieces of information for each record
     ' to distinguish rows better, there are 2 sets of colors
   masColor(1, 1) = "#550055" 'red-blue 'red-blue 
   masColor(1, 2) = "#cc0000" 'light red 'light red 
   masColor(1, 3) = "#770000" 'medium red 'medium red 

   masColor(2, 1) = "#00bbcc" ' green-blue ' green-blue 
   masColor(2, 2) = "#008800" 'medium green 'medium green 
   masColor(2, 3) = "#00bb00" 'light green 'light green 
End Sub

Sub test_1_Create_HtmlCalendar()
  '170723 s4p
  'as you modify this code, give the procedure a better name and add error handling
  '  launcher to create calendar report for a web browser from a query
  '  path\file will be named automatically
  '  no calendar title is specified in the query
   Application.FollowHyperlink Create_HtmlCalendar("qCalendarText1Only")
End Sub

Sub test_2_Create_HtmlCalendar_SpecifyFile()
  '170723 s4p
  'as you modify this code, give the procedure a better name and add error handling
  '  launcher to create calendar report for a web browser from a query
  ' since path not specified, it will be chosen
  ' since file has no extension, _yymmdd-hhnn.htm will be added to end
   Application.FollowHyperlink Create_HtmlCalendar("qCalendar_Jobs", "Jobs")
End Sub

Function test_3_Create_HtmlCalendar_AskQueryName() As Boolean
  '170723 s4p
  'as you modify this code, give the procedure a better name and add error handling
  '  prompt for Query Name to create calendar from
  '  file name and path will be calculated
   Dim sQueryName As String
   sQueryName = InputBox("Enter Query Name to create calendar from")
   If sQueryName <> "" Then
      Application.FollowHyperlink Create_HtmlCalendar(sQueryName)
      test_3_Create_HtmlCalendar_AskQueryName = True
   End If
End Function

Sub test_4_Create_HtmlCalendar()
  '...170322 s4p
  'as you modify this code, give the procedure a better name and add error handling
  '  launcher to create calendar report for a web browser
  '     define SQL
  '     specify filename for output

   Dim sSQL As String _
   , sFilename As String

  '   sSQL = "MyQueryName"
        'OR
   sSQL = "SELECT ""Calendar for "" & ([c_Contact].[NameA]+"" "") & [c_Contact].[MainName] AS CalTitle" _
      & ", c_Appointment.dtmAppt" _
      & ", DateValue([c_Appointment].[dtmAppt]) AS CalDate" _
      & ", Format(TimeValue([c_Appointment].[dtmAppt]),""Medium Time"") AS Text1" _
      & ", c_Contact_1.NameA AS Text2" _
      & ", [c_ApptType].[TypAppt] & ("" (""+[c_Appointment].[StatusAppt]+"")"") AS Text3" _
      & " FROM c_ApptType" _
      & " INNER JOIN ((c_Contact" _
      & " RIGHT JOIN c_Appointment" _
      & "   ON c_Contact.CID = c_Appointment.CIDcal)" _
      & " LEFT JOIN c_Contact AS c_Contact_1" _
      & "   ON c_Appointment.CIDwith = c_Contact_1.CID)" _
      & "   ON c_ApptType.TypIDappt = c_Appointment.TypIDappt" _
      & " ORDER BY c_Appointment.dtmAppt" _
      & ";"

   sFilename = "MyReportname.html"

   sFilename = Create_HtmlCalendar(sSQL, sFilename)
   Application.FollowHyperlink sFilename

End Sub

  '------------------------------------------------- Create_HtmlCalendar
Function Create_HtmlCalendar( _
   psQueryOrSQL As String _
   , Optional ByVal psPathFile As String = "" _
   ) As String
  'create calendar report for a web browser
  '160523 ... 170723 strive4peace

     'CALLS
     'SetTheColors
     'StartTime
     'EndTime
     'WriteHTMLheader
     'WriteHTMLfooter
     'DoesFieldExistInRs
     'GetFilenameFromPathFile

     'PARAMETERS
     'query or SQL statement needs to have values (for desired month) and be sorted by CalDate
     '  psPathFile is the path\filename.ext to create with the results
     '     _yymmdd-hhnn.HTM added if no extension specified
     '  if not specified, will be called Calendar... in CurrentProject.Path\Calendar\

     'QUERY FIELDS
     ' CalDate - calendar date - REQUIRED
     ' CalTitle - calendar title - OPTIONAL - read from first record
     ' Text1 - first text in cell - OPTIONAL
     ' Text2 - second text in cell - OPTIONAL
     ' Text3 - third text in cell - OPTIONAL

     'if no data is written in the cell, the day number in the cell
     'will still be colored if there is a record

     'RETURNS
     '  path\filename of calendar that was generated
     '     if not successful: ""

     'EXAMPLEs:
     '  call Create_HtmlCalendar("qCalendar")
     '  MsgBox Create_HtmlCalendar("qCalendar_NoCellText")
     '  Application.FollowHyperlink Create_HtmlCalendar("qCalendarText1Only")

     'assume calendar was not successful
   Create_HtmlCalendar = ""

     'set up error handler
   On Error GoTo Proc_Err

     'set StartTime to time how long it takes
   Call StartTime

     'dimension variables
   Dim db As DAO.Database _
      , rs As DAO.Recordset _
      , qdf As DAO.QueryDef

   Dim iFileNumber As Integer _
      , nNumDaysWithData As Integer _
      , iCol As Integer _
      , iColWidth As Integer _
      , iColor As Integer _
      , iDOW1 As Integer _
      , iDOW2 As Integer _
      , i As Integer _
      , nDate1 As Date _
      , nDate2 As Date _
      , ndate As Date _
      , sPath As String _
      , sFilename As String _
      , sParameter As String _
      , sColor1 As String _
      , sColor2 As String _
      , sColor3 As String _
      , sCalTitle As String _
      , vCriteria As Variant _
      , boo1 As Boolean _
      , boo2 As Boolean _
      , boo3 As Boolean _
      , booDayData As Boolean

   sPath = ""
   sFilename = ""

     'Call Set The Colors
   Call SetTheColors

   nNumDaysWithData = 0

   iColWidth = 168 '150 for narrower '150 for narrower 

   vCriteria = Null

   Set db = CurrentDb
     'see query with parameters was passed
   If Left(psQueryOrSQL, 7) <> "SELECT " Then
      If db.QueryDefs(psQueryOrSQL).Parameters.Count > 0 Then
         Set qdf = db.QueryDefs(psQueryOrSQL)
         With qdf
            For i = 1 To .Parameters.Count
               With .Parameters(i - 1)
                  .Value = InputBox(.Name, "Enter Query Parameter")
                    'criteria is written on Calendar report below main title
                  vCriteria = (vCriteria + ", ") & .Value
               End With 'Parameter 'Parameter 
            Next i
         End With 'qdf 'qdf 
         Set rs = qdf.OpenRecordset(dbOpenDynaset, dbSeeChanges)
      End If
   End If
   If rs Is Nothing Then
      Set rs = db.OpenRecordset(psQueryOrSQL, dbOpenDynaset, dbSeeChanges)
   End If

   If Not DoesFieldExistInRs(rs, "CalDate") Then
      MsgBox "CalDate is Missing from the specified recordset" _
         & vbCrLf & vbCrLf & "Calendar cannot be generated " _
         & "without a field called 'CalDate'" _
         & vbCrLf & vbCrLf & "For instructions, Read comments for " _
         & "Create_HtmlCalendar" _
         , , "Field named 'CalDate' is Required"
      GoTo Proc_Exit
   End If

   With rs
      If .EOF Then
         MsgBox "Calendar has no dates in specified range", , "No Data"
         .Close
         Set rs = Nothing

         GoTo Proc_Exit
      End If
      .MoveFirst


      booDayData = False

      If DoesFieldExistInRs(rs, "CalTitle") Then
         sCalTitle = rs!CalTitle
      Else
         sCalTitle = "Calendar"
      End If

      boo1 = DoesFieldExistInRs(rs, "Text1")
      boo2 = DoesFieldExistInRs(rs, "Text2")
      boo3 = DoesFieldExistInRs(rs, "Text3")

      nDate1 = DateSerial(Year(!CalDate), Month(!CalDate), 1) ' 1st day of specified month/year ' 1st day of specified month/year 
      nDate2 = DateSerial(Year(!CalDate), Month(!CalDate) + 1, 0) ' last day of specified month/year ' last day of specified month/year 

        '------------- determine path\filename
        'see if psPathFile was specified
      If psPathFile = "" Then
           'use calendar title for filename -- replace spaces with _ underscore
         sFilename = Replace(sCalTitle, " ", "_")
      Else
         sFilename = GetFilenameFromPathFile(psPathFile)
         If Len(sFilename) <> Len(psPathFile) Then
            sPath = Left(psPathFile, Len(psPathFile) - Len(sFilename))
         End If
      End If

      If sFilename = "" Then
           'use calendar title for filename -- replace spaces with _ underscore
         sFilename = Replace(sCalTitle, " ", "_")
      End If

        'if file has no extension, add Mon-Yr for calendar _
                                   and _yymmdd-hhnn for when generated _
                                   and .HTM
      If Not InStr(sFilename, ".") > 0 Then
         sFilename = sFilename _
            & "_" & Format(nDate1, "mmm-yyyy") _
            & "_" & Format(Now(), "yymmdd-hhnn") _
            & ".htm"
      End If

        'use \CALENDAR under CurrentProject.Path if path not specified
      If Trim(sPath) = "" Then
         sPath = CurrentProject.Path & "\CALENDAR\"
         If Dir(sPath, vbDirectory) = "" Then
            MkDir sPath
         End If
      End If
      psPathFile = sPath & sFilename

      iDOW1 = Weekday(nDate1)
      iDOW2 = Weekday(nDate2)
        '*************************************************************************************
        '-------------------------------------------------------------------- create web page

      iFileNumber = FreeFile

      On Error Resume Next
      Close #iFileNumber

      If Dir(psPathFile) <> "" Then
         Kill psPathFile
       '    DoEvents: DoCmd.Hourglass True
      End If

        '-------------------------------------------------------------------- ~header
      On Error GoTo Proc_Err
      Open psPathFile For Output As #iFileNumber
      Call WriteHTMLheader(iFileNumber _
         , Format(!CalDate, "mmmm yyyy") _
         , sCalTitle _
         , Nz(vCriteria, "") _
         )

        'define table
      Print #iFileNumber, "<BR>"
      Print #iFileNumber, "<TABLE border=2 CELLPADDING=2 WIDTH = " & 7 * iColWidth & ">"
      Print #iFileNumber, Space(2) & "<TR>"

        'print days of week
      For iCol = 1 To 7
         Print #iFileNumber, Space(4) & "<td ALIGN=center VALIGN=center WIDTH = " & iColWidth & ">"
         Print #iFileNumber, Space(6) & "<font size = 2>"
         Print #iFileNumber, Space(8) & Mid("SunMonTueWedThuFriSat", (iCol - 1) * 3 + 1, 3)
         Print #iFileNumber, Space(6) & "</font>"
         Print #iFileNumber, Space(4) & "</td>"
      Next iCol

      Print #iFileNumber, Space(2) & "</TR>"

        '-------------------------------------------------------------------- ~detail
        'print information on days
        'start a new row
      Print #iFileNumber, Space(2) & "<TR>"

        'determine number of squares before the calendar starts
      If iDOW1 <> 1 Then
         Print #iFileNumber, Space(4) & "<td  VALIGN=top WIDTH = " & iColWidth _
               & " COLSPAN=" & (iDOW1 - 1) & ">"
         Print #iFileNumber, Space(4) & "</td>"
      End If

      For ndate = nDate1 To nDate2
           'see if we need to go to another row
         If Weekday(ndate) = 1 And Day(ndate) <> 1 Then
              'go to another row
            Print #iFileNumber, Space(2) & "</TR>"
            Print #iFileNumber, Space(2) & "<TR>"
         End If
           '-------------- print day number
         Print #iFileNumber, Space(4) & "<td  VALIGN=top WIDTH = " & iColWidth & ">"
         Print #iFileNumber, Space(6) & "<p ALIGN=right>"
         Print #iFileNumber, Space(8) & "<font size = 3"

         iColor = 0 'so color will change to 1 for 1st entry on a date 'so color will change to 1 for 1st entry on a date 

           'see if there is any data for this day
         If Not .EOF() Then
            If !CalDate = ndate Then
               booDayData = True
               Print #iFileNumber, Space(10) & "color = blue><b>"
               nNumDaysWithData = nNumDaysWithData + 1
            Else
               booDayData = False
               Print #iFileNumber, Space(10) & "color = gray>"
            End If
         Else
            Print #iFileNumber, Space(10) & "color = gray>"
         End If

         Print #iFileNumber, Space(10) & CStr(Day(ndate)) & " "
         If booDayData Then
            Print #iFileNumber, Space(8) & "</b>";
         Else
            Print #iFileNumber, Space(8);
         End If

         Print #iFileNumber, "</font>"
         Print #iFileNumber, Space(6) & "</p>"

         Print #iFileNumber, Space(6) & "<p ALIGN=left>"
         Print #iFileNumber, Space(8) & "<font face=""Verdana"" size=1 color=green>"

         If Not .EOF Then
            If !CalDate = ndate Then
               Do
                  If .EOF Then GoTo End_Of_Day

                    'switch colors
                  If iColor <> 1 Then
                     iColor = 1
                  Else
                     iColor = 2
                  End If

                  sColor1 = masColor(iColor, 1)
                  sColor2 = masColor(iColor, 2)
                  sColor3 = masColor(iColor, 3)

                  If boo1 Then
                     If Len(!Text1 & "") > 0 Then
                        Print #iFileNumber, Space(8) & "<font color=" & sColor1 & ">"
                        Print #iFileNumber, Space(10) & "<b> " & !Text1 & " </b> "
                        Print #iFileNumber, Space(8) & "</font>"
                     End If
                  End If

                  If boo2 Then
                     If Len(!Text2 & "") > 0 Then
                        Print #iFileNumber, Space(8) & "<font color=" & sColor2 & ">"
                        Print #iFileNumber, Space(10) & !Text2
                        Print #iFileNumber, Space(8) & "</font>"
                     End If
                  End If

                  If boo3 Then
                     If Len(!Text3 & "") > 0 Then
                        Print #iFileNumber, Space(8) & "<font color=" & sColor3 & ">"
                        Print #iFileNumber, Space(10) & !Text3
                        Print #iFileNumber, Space(8) & "</font>"
                     End If
                  End If

                    'print line break if there was any data
                  If boo1 Or boo2 Or boo3 Then Print #iFileNumber, Space(8) & "<BR/>"

                  If .EOF Then GoTo End_Of_Day
                  .MoveNext
                  If .EOF Then GoTo End_Of_Day
                  If !CalDate <> ndate Then GoTo End_Of_Day

               Loop While !CalDate = ndate
            End If '!CalDate = ndate '!CalDate = ndate 
         End If 'Not .EOF 'Not .EOF 
End_Of_Day:

         Print #iFileNumber, Space(8) & "</font>"
         Print #iFileNumber, Space(6) & "</p>"
nextCol:
         Print #iFileNumber, Space(4) & "</td>"

      Next ndate

      Print #iFileNumber, Space(2) & "</TR>"
      Print #iFileNumber, "</table>"

      .Close
   End With 'rs 'rs 
   Set rs = Nothing

     '--------------------------------------- number of days
   Print #iFileNumber, " "
   Print #iFileNumber, "<font face=""Verdana"" size=1 color=green>"
   Print #iFileNumber, Space(4) _
               & Format(nNumDaysWithData, "0") & " Days with information"

   Print #iFileNumber, "</font>"

     '--------------------------------------- date
   Print #iFileNumber, "<font size=2 color = gray><i>"
   Print #iFileNumber, Space(2) & "   Generated "
   Print #iFileNumber, Space(2) & Format(Now, "dd-mmm-yyyy, ddd, h:mm am/pm")
   Print #iFileNumber, "</i></font>"

   WriteHTMLfooter iFileNumber
   Close #iFileNumber
   DoEvents: DoCmd.Hourglass True

Create_HtmlCalendar_exit:

  '   On Error Resume Next

   Debug.Print "Simple HTML calendar written by crystal (strive4peace)" & vbCrLf & vbCrLf _
      & "Done generating " & vbCrLf & vbCrLf _
      & psPathFile

   Create_HtmlCalendar = psPathFile

Proc_Exit:
   Call EndTime
   On Error Resume Next
   Set qdf = Nothing

   If Not rs Is Nothing Then
      rs.Close
      Set rs = Nothing
   End If
   Set db = Nothing
   Exit Function

Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   Create_HtmlCalendar"
   Resume Proc_Exit
   Resume

End Function

  '------------------------------------------------- WriteHTMLheader
Private Function WriteHTMLheader(iFileNumber As Integer, _
    psTitleMain As String _
    , psTitleAbove As String _
    , psTitleBelow As String _
    )
  's4p
   Print #iFileNumber, "<html>"
   Print #iFileNumber, "<head>"
   Print #iFileNumber, Space(2) & "<title>"
   If Len(Trim(psTitleAbove)) <> 0 Then
      Print #iFileNumber, Space(6) & psTitleAbove
   End If
   If Len(Trim(psTitleMain)) <> 0 Then
      Print #iFileNumber, Space(6) & psTitleMain
   End If
   Print #iFileNumber, Space(2) & "</title>"

   Print #iFileNumber, Space(2) & "<META NAME=""Keywords"" CONTENT=""" _
      & psTitleAbove & " " & psTitleMain & " " & psTitleBelow _
      & """>"
   Print #iFileNumber, "</head>"
   Print #iFileNumber, "<Body>"
     '----------------------- customize
   Print #iFileNumber, "<a name=top></a>"

   Print #iFileNumber, "<center>"
   If Len(Trim(psTitleAbove)) <> 0 Then
      Print #iFileNumber, Space(1) & "<font size=4 color = green>"
      Print #iFileNumber, Space(3) & psTitleAbove
      Print #iFileNumber, Space(1) & "</font>"
      Print #iFileNumber, Space(1) & "<BR> "
   End If
   If Len(Trim(psTitleMain)) <> 0 Then
      Print #iFileNumber, Space(1) & "<font size=5 color = black>"
      Print #iFileNumber, Space(3) & "<B>"
      Print #iFileNumber, Space(5) & psTitleMain
      Print #iFileNumber, Space(3) & "</B>"
      Print #iFileNumber, Space(1) & "</font>"
   End If
   If Len(Trim(psTitleBelow)) <> 0 Then
      Print #iFileNumber, Space(1) & "<BR> "
      Print #iFileNumber, Space(1) & "<font size=4 color = green>"
      Print #iFileNumber, Space(3) & psTitleBelow
      Print #iFileNumber, Space(1) & "</font>"
   End If
   Print #iFileNumber, "<BR>"

End Function

  '------------------------------------------------- WriteHTMLfooter
Private Function WriteHTMLfooter( _
   iFileNumber As Integer _
   , Optional pBooPrintBy As Boolean = False)
   's4p
   Print #iFileNumber, "<a name=bottom></a>"
   Print #iFileNumber, "<HR>"

   If Nz(pBooPrintBy, False) Then
      Print #iFileNumber, "<BR>"
      Print #iFileNumber, "<font size=2><i>";
      Print #iFileNumber, "Generated " & Format(Now(), "ddd, m-d-yy h:nn am/pm");
      Print #iFileNumber, "</i></font>"
   End If
   Print #iFileNumber, "</center>"

   Print #iFileNumber, "<font size=1 color=purple>";
   Print #iFileNumber, "strive4peace</font>"

   Print #iFileNumber, "</body>"
   Print #iFileNumber, "</html>"

End Function

Private Function cal_GetCol4Calendar(pDate As Date) As Integer
  's4p
   cal_GetCol4Calendar = 0
   cal_GetCol4Calendar = Weekday(pDate, vbSunday)
End Function

Private Function cal_GetRow4Calendar(pDate As Date) As Integer
  's4p

   On Error GoTo Proc_Err
   cal_GetRow4Calendar = 0

   Dim nCol_First As Integer _
      , nDate_First As Date _
      , nRow As Integer _
      , nCol As Integer _
      , nNumDaysRow1 As Integer

   nDate_First = DateSerial(Year(pDate), Month(pDate), 1)
   nCol_First = Weekday(nDate_First, vbSunday)
   nNumDaysRow1 = 7 - nCol_First + 1

   nCol = Weekday(pDate, vbSunday)

   nRow = (Day(pDate)) \ 7 + 1

   If Day(pDate) Mod 7 > nNumDaysRow1 Then nRow = nRow + 1
   If Day(pDate) Mod 7 = 0 And nCol >= nCol_First Then nRow = nRow - 1

   cal_GetRow4Calendar = nRow

Proc_Exit:
   On Error Resume Next
   Exit Function

Proc_Err:
   MsgBox Err.Description, , _
       "ERROR " & Err.Number _
        & "   cal_GetRow4Calendar"

   Resume Proc_Exit
   Resume
End Function

Public Sub test_DoesFieldExistInRs()
  '170719 s4p
  On Error GoTo Proc_Err

   Dim sSQL As String _
      , sFieldname As String

   Dim db As DAO.Database _
      , rs As DAO.Recordset

     '---------------------------------- customize
   sSQL = "SELECT c_Contact.* " _
      & " FROM c_Contact" _
      & " ;"

   Set db = CurrentDb
   Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)

   With rs
      sFieldname = "CID"
      MsgBox DoesFieldExistInRs(rs, sFieldname), , sFieldname
      sFieldname = "NotThere" '-------- customize '-------- customize 
      MsgBox DoesFieldExistInRs(rs, sFieldname), , sFieldname
      .Close
   End With

Proc_Exit:
   On Error Resume Next
     'release object variables if applicable-- ie:
   If Not rs Is Nothing Then
      rs.Close
      Set rs = Nothing
   End If
   Set db = Nothing
   Exit Sub

Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   test_DoesFieldExistInRs "

   Resume Proc_Exit
   Resume
End Sub

Public Function DoesFieldExistInRs(pRs As DAO.Recordset, psFieldname As String) As Boolean
  '170719 s4p
  On Error GoTo Proc_Err

   Dim sName As String

   With pRs
      sName = pRs(psFieldname).Name
   End With
   DoesFieldExistInRs = True

Proc_Exit:
   On Error Resume Next
   Exit Function

Proc_Err:
  '   MsgBox Err.Description, , _
          "ERROR " & Err.Number _
          & "   DoesFieldExistInRs "

   Resume Proc_Exit
   Resume

End Function

Function OpenCalendarFolder() As Boolean
  's4p
   Dim sPath As String
   sPath = CurrentProject.Path & "\CALENDAR\"
   Application.FollowHyperlink sPath
   OpenCalendarFolder = True
End Function

  '---------------------------------------------------- Local copies of functions that could be general
Private Function EndTime() As String
  's4p
     'mStartTime is dimensioned for module or project
   EndTime = DateDiff("s", mStartTime, Now()) & " seconds"
   Debug.Print "--- END-------------" & EndTime
   DoCmd.Hourglass False
End Function

Private Sub StartTime(Optional psMsg)
  's4p
   On Error Resume Next
     'mStartTime is dimensioned for module or project
   mStartTime = Now()
   DoCmd.Hourglass True
   If IsMissing(psMsg) Then Exit Sub
   Debug.Print "--- START-------------" & psMsg & " ----- " & CStr(mStartTime)
End Sub

  'Private
Function GetFilenameFromPathFile( _
   psPathFile As String _
   , Optional psDelimiter As String = "\" _
   ) As String
  '170726 strive4peace
   Dim arrParts() As String
   GetFilenameFromPathFile = psPathFile
   arrParts = Split(psPathFile, psDelimiter)
   GetFilenameFromPathFile = arrParts(UBound(arrParts))
End Function