[AccessD] MSAccess HTML Text Box - part two

[John Colby]

I learn something new every day.  Thanks to Stuart for pointing out
the plain text mode option in GMail.

Option Compare Database
Option Explicit
'.=========================================================================
'.Copyright 2022 Colby Consulting.  All rights reserved.
'.Phone        :
'.E-mail       : jcolby at colbyconsulting.com
'.=========================================================================
' DO NOT DELETE THE COMMENTS ABOVE.  All other comments in this module
' may be deleted from production code, but lines above must remain.
'--------------------------------------------------------------------------
'.Description  :
'.
'.Written By   : John W. Colby
'.Date Created : 07/12/2022
' Rev. History :
'
' Comments     : This class handles writing stuff to a text box for debug
'                purposes
'.-------------------------------------------------------------------------
'.
' ADDITIONAL NOTES:
'
'--------------------------------------------------------------------------
'
' INSTRUCTIONS:
'.--------------------------------------------------------------------------
'.
'.
' BEHAVIORS:
'
'--------------------------------------------------------------------------
'THESE CONSTANTS AND VARIABLES ARE USED INTERNALLY TO THE CLASS
'*+ Class constant declaration
Private Const DebugPrint As Boolean = True
Private Const mcstrModuleName As String = "clsHTMLTextBox"
Private Const mstrBereakLine As String = _
"++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"

'*- Class constants declaration

'*+ Class variables declarations
Private mtxtHTML As TextBox
Private mstrHTMLMsg As String   'The html formatted string being built
and displayed
Private mstrUnformattedMsg As String 'The unformatted version of the
HTML formatted string for logging
Private mcolMsgStrings As Collection
'Private mcolFormats As Collection

'*- Class variables declarations
'.-------------------------------------------------------------------------
'THESE CONSTANTS AND VARIABLES ARE USED BY THE CLASS TO IMPLEMENT
CLASS FUNCTIONALITY
'*+ custom constants declaration
'
'*- Custom constants declaration
'*+ custom variables declarations
'
'*- custom variables declarations
'
'Define any events this class will raise here
'*+ custom events Declarations
Public Event evStatus(intStatus As enumVBColors, strStatus As String)
Public Event evError(intStatus As enumVBColors, strError As String)

Property Get pUnformattedMsg(Optional blnBreakLines As Boolean = True) As String

Dim lclsHTMLFormat As clsHTMLFormat

    mstrUnformattedMsg = ""

    For Each lclsHTMLFormat In pcolMsgStrings
        If lclsHTMLFormat.pCRLF Then
            mstrUnformattedMsg = mstrUnformattedMsg &
lclsHTMLFormat.pToFormat() & vbCrLf
            'Debug.Print lclsHTMLFormat.pToFormat() & vbCrLf
        Else
            mstrUnformattedMsg = mstrUnformattedMsg & " " &
lclsHTMLFormat.pToFormat()
            'Debug.Print lclsHTMLFormat.pToFormat()
        End If
        'Debug.Print mstrUnformattedMsg
    Next
    If blnBreakLines Then
        Dim str As String
        str = mstrBereakLine & mstrUnformattedMsg
        pUnformattedMsg = str
    Else
        pUnformattedMsg = mstrUnformattedMsg
    End If

End Property '*- custom events declarations
'.-------------------------------------------------------------------------
'THESE FUNCTIONS / SUBS ARE USED INTERNALLY TO THE CLASS
'*+ Private Init/Terminate Interface
Private Sub Class_Initialize()
On Error GoTo Err_Class_Initialize
    'assDebugPrint "initialize " & mcstrModuleName, DebugPrint
    RaiseEvent evStatus(0, "Class_Initialized")

Exit_Class_Initialize:
Exit Sub
Err_Class_Initialize:
        MsgBox err.Description, , "Error in Sub clsTemplate.Class_Initialize"
        Resume Exit_Class_Initialize
    Resume 0    '.FOR TROUBLESHOOTING
End Sub
Private Sub Class_Terminate()
On Error Resume Next
    'assDebugPrint "Terminate " & mcstrModuleName, DebugPrint
    Set mcolMsgStrings = Nothing
    'Set mcolFormats = Nothing
    Term
    Set mtxtHTML = Nothing
    RaiseEvent evStatus(0, "Class_Terminated")
End Sub
'INITIALIZE THE CLASS
'
'Receive an HTML enabled text box and save it to the variable in the header
'
Public Sub Init(ByRef robjParent As Object, ltxtStatus As TextBox)
    Set mtxtHTML = ltxtStatus
    mtxtHTML.TextFormat = acTextFormatHTMLRichText
    Set mcolMsgStrings = New Collection 'Init the collection to store
the clsHTMLFormat instances in
    'IF THE PARENT OBJECT HAS A CHILDREN COLLECTION, PUT MYSELF IN IT
    RaiseEvent evStatus(0, "Init Completed")
End Sub
'CLEAN UP ALL OF THE CLASS POINTERS
Public Sub Term()
Static blnRan As Boolean    'The term may run more than once so
    If blnRan Then Exit Sub 'just exit if it already ran
    blnRan = True
    On Error Resume Next
    'assDebugPrint "Term() " & mcstrModuleName, DebugPrint
    'remove this class' pointer from the troubleshooting pointer class
    RaiseEvent evStatus(0, "Term Completed")
End Sub
'*- Public Init/Terminate interface
'get the name of this class / module
Property Get pHTMLMsg() As String
    pHTMLMsg = mstrHTMLMsg
End Property

Property Get pTextBoxVal()
    mtxtHTML.SetFocus
    pTextBoxVal = mtxtHTML.Text
End Property
Property Get ptxtHTML() As TextBox
    Set ptxtHTML = mtxtHTML
End Property
Property Get pcolMsgStrings() As Collection
    Set pcolMsgStrings = mcolMsgStrings
End Property

'.-------------------------------------------------------------------------
'THESE FUNCTIONS SINK EVENTS DECLARED WITHEVENTS IN THIS CLASS
'*+ Form WithEvent interface
'*- Form WithEvent interface
'THESE FUNCTIONS / SUBS ARE USED TO IMPLEMENT CLASS FUNCTIONALITY
'*+PRIVATE Class function / sub declaration
'*-PRIVATE Class function / sub declaration
'*+PUBLIC Class function / sub declaration

Function fClrTextBox()
    mtxtHTML.SetFocus
    mtxtHTML.Text = ""
End Function
Function HTMLColour(VBAColor As Long) As String
    HTMLColour = "#" & Right$("000000" & Hex$(VBAColor), 6)
End Function
'
'This function receives an already created clsHTMLFormat, adds it to
the collection
'And writes the formatted string from the clsHTMLFormat passed into
this function
'into the HTML enabled text box.
'
Function fWriteFormatted(lclsHTMLFormat As clsHTMLFormat)
On Error GoTo fWriteFormatted_Error

    mcolMsgStrings.Add lclsHTMLFormat
    '
    'Now append it to the HTMLMsgString
    mstrHTMLMsg = mstrHTMLMsg & lclsHTMLFormat.pFormatted
    '
    'And finally append it to the text box
    mtxtHTML.SetFocus
    mtxtHTML.Text = mstrHTMLMsg 'lclsHTMLFormat.pFormatted


Exit_fWriteFormatted:
    On Error GoTo 0
    Exit Function

fWriteFormatted_Error:
Dim strErrMsg As String
    Select Case err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        strErrMsg = "Error " & err.Number & " (" & err.Description &
") in procedure LicenseTest.clsHTMLTextBox.fWriteFormatted, line " &
Erl & "."
        Beep
#If boolELE = 1 Then
        WriteErrorLog strErrMsg
#End If
        assDebugPrint strErrMsg
        Resume Exit_fWriteFormatted
    End Select
    Resume Exit_fWriteFormatted
    Resume 0    'FOR TROUBLESHOOTING
End Function
'
'This function creates an instance of clsHTMLFormat, receiving the
string to be formatted
'as well as all of the formatting info.  Much of that is a reasonable
default so nothing
'is required unless a change is desired.
'
'The received string and format info is passed into the new
clsHTMLFormat instance
'where the string is stored and all formatting is applied.
'The pointer to the new clsHTMLFormat instance is then saved into a
collection mcolMsgStrings
'
'Then the formatted string is written into the HTML enabled text box.
'
Function fWriteRaw(lstrToFormat As String, _
                            Optional blnCRLF As Boolean = True, _
                            Optional blnBold As Boolean = False, _
                            Optional blnItalics As Boolean = False, _
                            Optional blnUnderline As Boolean = False, _
                            Optional intSize As Integer = -1, _
                            Optional strColor As String = "Black", _
                            Optional strFace As String = "Arial", _
                            Optional intStatus As enumVBColors =
enumVBColors.Black, _
                            Optional intAlign As enumAlign = 1)
    On Error GoTo fWriteRaw_Error
Dim lclsHTMLFormat As clsHTMLFormat
    Set lclsHTMLFormat = New clsHTMLFormat
    lclsHTMLFormat.fInit lstrToFormat, blnCRLF, blnBold, blnItalics, _
                            blnUnderline, intSize, strColor, strFace,
intStatus, intAlign
    '
    'Save each string into a collection
    '
    mcolMsgStrings.Add lclsHTMLFormat
    'Debug.Print lclsHTMLFormat.pFormatted
    'Exit Function
    '
    'Now append it to the HTMLMsgString
    mstrHTMLMsg = mstrHTMLMsg & lclsHTMLFormat.pFormatted
    '
    'And finally append it to the text box
    mtxtHTML.SetFocus
    mtxtHTML.Text = mstrHTMLMsg 'lclsHTMLFormat.pFormatted
    'Debug.Print mtxtHTML.Text
Exit_fWriteRaw:
    On Error GoTo 0
    Exit Function

fWriteRaw_Error:
Dim strErrMsg As String
    Select Case err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case 2176   'Too long for the text box
        strErrMsg = "Error " & err.Number & " (" & err.Description &
") in procedure LicenseTest.clsHTMLTextBox.fWriteRaw, line " & Erl &
"."
    Case 2101   'No idea yet
        strErrMsg = "Error " & err.Number & " (" & err.Description &
") in procedure LicenseTest.clsHTMLTextBox.fWriteRaw, line " & Erl &
"."
    Case Else   'All other errors will trap
        strErrMsg = "Error " & err.Number & " (" & err.Description &
") in procedure LicenseTest.clsHTMLTextBox.fWriteRaw, line " & Erl &
"."
    End Select
    Beep
#If boolELE = 1 Then
    WriteErrorLog mtxtHTML.Name & " : " & strErrMsg
#End If
    assDebugPrint mtxtHTML.Name & " : " & Len(mtxtHTML) & " : " &
strErrMsg, DebugPrint
    RaiseEvent evError(Red, mtxtHTML.Name & " : " & strErrMsg)
    Resume Exit_fWriteRaw
    Resume 0    'FOR TROUBLESHOOTING
End Function
'
'This function allows the HTML Savy dev to just pass in an HTML formatted string
'Probably not a good idea since the HTML Savy text box only
understands a limited
'subset of all HTML fortmatting stuff.
'
'Additionally there will be no "plain text" unformatted string to log.
'
'But almost certainly someone somewhere will want to do this.
'
'You've been warned, not a good idea.
'
Function fWriteHTMLFromDev(strHTMLToWrite As String)
    On Error GoTo fWriteHTMLFromDev_Error
Dim lclsHTMLFormat As clsHTMLFormat
    Set lclsHTMLFormat = New clsHTMLFormat
    lclsHTMLFormat.pFormatted = strHTMLToWrite
    '
    'Save each string into a collection
    '
    mcolMsgStrings.Add lclsHTMLFormat
    'Debug.Print lclsHTMLFormat.pFormatted
    'Exit Function
    '
    'Now append it to the HTMLMsgString
    mstrHTMLMsg = mstrHTMLMsg & lclsHTMLFormat.pFormatted
    '
    'And finally append it to the text box
    mtxtHTML.SetFocus
    mtxtHTML.Text = mstrHTMLMsg 'lclsHTMLFormat.pFormatted


Exit_fWriteHTMLFromDev:
    On Error GoTo 0
    Exit Function

fWriteHTMLFromDev_Error:
Dim strErrMsg As String
    Select Case err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        strErrMsg = "Error " & err.Number & " (" & err.Description &
") in procedure LicenseTest.clsHTMLTextBox.fWriteHTMLFromDev, line " &
Erl & "."
        Beep
#If boolELE = 1 Then
        WriteErrorLog strErrMsg
#End If
        assDebugPrint strErrMsg
        Resume Exit_fWriteHTMLFromDev
    End Select
    Resume Exit_fWriteHTMLFromDev
    Resume 0    'FOR TROUBLESHOOTING
End Function
'*-PUBLIC Class function / sub declaration

--
John W. Colby
Colby Consulting