Userform textbox, account for Backspace and Delete

This userform edits cell contents as you type, while preserving the font.

The initiation starts at the class module "clsTextBox". There are two methods. (1) "MyTextBox_Change" is used when the cursor is placed somewhere before typing begins. (2) "MyTextBox_KeyPress" is used if part of the text is highlighted before typing.

There is an issue if the BACKSPACE or DELETE key is used, it throws out the fonts.

Is there a way to capture the BACKSPACE and DELETE event? So I can write a separate module for this.



CLASS MODULE clsTextBox

Private WithEvents MyTextBox As MSForms.TextBox

Public Property Set Control(tb As MSForms.TextBox)
    Set MyTextBox = tb
End Property

Private Sub MyTextBox_Change()
    Call UserFormFormulas.transfer(MyTextBox.SelLength)
End Sub

Private Sub MyTextBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Call UserFormFormulas.transfertwo(MyTextBox.SelLength)
End Sub

FORM CODE

Option Explicit

Private WithEvents MyApplication As Excel.Application
Public WithEvents cDelegate As ClassFormulasDelegate
Private TextBoxes As Collection
Private mActiveTextBox As MSForms.TextBox
Dim Buttons() As New ClassFormulasEvents

Private mTxtBoxes As Collection
Dim tbCollection As Collection

'INITIALIZE
Private Sub UserForm_Initialize()
    Set cDelegate = New ClassFormulasDelegate
    Call FormCreation(True)
    
    Dim ctrl As MSForms.Control
    Dim obj As clsTextBox
    Set tbCollection = New Collection
        For Each ctrl In Me.Controls
            If TypeOf ctrl Is MSForms.TextBox Then
                Set obj = New clsTextBox
                Set obj.Control = ctrl
                tbCollection.Add obj
            End If
        Next ctrl
    Set obj = Nothing
End Sub

'ACTIVATE
Private Sub UserForm_Activate()
    ButtonExit.SetFocus
End Sub

'CREATE FORM
Private Sub FormCreation(BuildButtons As Boolean)
    Dim cEvents As ClassFormulasEvents
    Dim Box As MSForms.TextBox
    Dim BoxTop As Long, BoxHeight As Long, BoxLeft As Long, BoxWidth As Long, BoxGap As Long
    Dim BoxName As String
    Dim cell As Range
    Dim MultiPageHeight As Double
    Dim MyControl As MSForms.Control
    Dim ButtonCount As Integer
    Dim index As Long
    'Introduction
    Set MyApplication = Application
    BoxHeight = 24: BoxTop = 0: BoxLeft = 0: BoxWidth = 388: BoxGap = 0
    index = 1
    If TextBoxes Is Nothing Then Set TextBoxes = New Collection
    'Create textboxes
    For Each cell In MyApplication.Selection
        If Not IsEmpty(cell) Then
            If index > TextBoxes.Count Then
                Set cEvents = New ClassFormulasEvents
                Set cEvents.cDelegate = cDelegate
                BoxName = "TextBox" & index
                Set Box = Me.TextBoxFrame.Controls.Add("Forms.Textbox.1", BoxName, True)
                Set cEvents.TextBoxGo = Box
                TextBoxes.Add cEvents
            Else
                Set Box = TextBoxes(index).TextBoxGo
            End If
            With Box
                .Height = BoxHeight: .top = BoxTop: .Left = BoxLeft: .width = BoxWidth
                .Font.Size = 12
                .Text = cell.Formula
                .AutoWordSelect = False
            End With
            index = index + 1
            BoxTop = BoxTop + BoxHeight + BoxGap
        End If
    Next
    'Remove extra textboxes
    Do While TextBoxes.Count > index
        TextBoxes.Remove TextBoxes.Count
    Loop
    'Size form for variable conditions
    Me.Height = BoxTop + MultiPageHeight + 148 'TRIAL & ERROR
    TextBoxFrame.Height = BoxTop
    'Create Command Button objects
    If BuildButtons Then
        ButtonCount = 0
        For Each MyControl In Me.Controls
            If TypeName(MyControl) = "CommandButton" Then
                ButtonCount = ButtonCount + 1
                ReDim Preserve Buttons(1 To ButtonCount)
                Set Buttons(ButtonCount).ButtonGroup = MyControl
            End If
        Next MyControl
    End If
End Sub

'RECEIVING EVENT
Private Sub cDelegate_TextBoxGoChanged(TextBoxGo As MSForms.TextBox)
    Set mActiveTextBox = TextBoxGo
End Sub

'INSERT CHARACTERS
Public Sub InsertCharacter(CharacterType As String) 'Public since called  from Class Module
    Dim TextBox As MSForms.TextBox
    Dim cell As Range
    Dim CursorLocation As Long
    Dim index As Long
    index = 1
    If mActiveTextBox Is Nothing Then
        Exit Sub 'To prevent error message
    End If
    For Each cell In MyApplication.Selection
        If Not IsEmpty(cell) Then
            If TextBoxes(index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
                    CursorLocation = .SelStart
                    'Insert character General Case
                    cell.Characters(.SelStart + 1, 0).Insert CharacterType
                    mActiveTextBox.Text = Left(.Text, .SelStart) & CharacterType & Mid(.Text, .SelStart + 1)
                    .SelStart = CursorLocation + Len(CharacterType)
                    .SetFocus 'Prevents the cursor from disappearing
                End With
            End If
        index = index + 1
        End If
        Next
End Sub

Sub transfer(SelectionCount As Long)
    Dim TextBox As MSForms.TextBox
    Dim cell As Range
    Dim CursorLocation As Long, cursorplaceholder As Long
    Dim characterarray() As String
    Dim fontarray() As String
    Dim index As Long
    Dim i As Long, j As Long
    index = 1
    For Each cell In MyApplication.Selection
        Application.ScreenUpdating = False
        If Not IsEmpty(cell) Then
            If TextBoxes(index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
CursorLocation = .SelStart
cursorplaceholder = CursorLocation
ReDim characterarray(Len(cell) - 1)
ReDim fontarray(Len(cell) - 1)
                For i = 1 To Len(cell)
                    characterarray(i - 1) = Mid$(cell, i, 1)
                    fontarray(i - 1) = cell.Characters(i, 1).Font.Name
                Next
'Transfer to cell
cell.value = mActiveTextBox.value
'Restore fonts
If SelectionCount = 0 Then
    If cursorplaceholder = 1 Then
    cell.Characters(1, 1).Font.Name = fontarray(0)
        For i = cursorplaceholder + 1 To Len(cell)
        cell.Characters(i, 1).Font.Name = fontarray(i - 2)
        Next
    End If
    If cursorplaceholder > 1 Then
        For i = 1 To cursorplaceholder - 1
        cell.Characters(i, 1).Font.Name = fontarray(i - 1)
        Next
        For i = cursorplaceholder To Len(cell)
        cell.Characters(i, 1).Font.Name = fontarray(i - 2)
        Next
    End If
End If
If SelectionCount > 0 Then
'do nothing
End If
                End With
            End If
        index = index + 1
        End If
        Application.ScreenUpdating = True
        Next
End Sub


Sub transfertwo(SelectionCount As Long)
  Dim TextBox As MSForms.TextBox
    Dim cell As Range
    Dim CursorLocation As Long, cursorplaceholder As Long
    Dim characterarray() As String
    Dim fontarray() As String
    Dim index As Long
    Dim i As Long, j As Long
    index = 1
    For Each cell In MyApplication.Selection
        Application.ScreenUpdating = False
        If Not IsEmpty(cell) Then
            If TextBoxes(index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
CursorLocation = .SelStart
cursorplaceholder = CursorLocation
ReDim characterarray(Len(cell) - 1)
ReDim fontarray(Len(cell) - 1)
            For i = 1 To Len(cell)
                characterarray(i - 1) = Mid$(cell, i, 1)
                fontarray(i - 1) = cell.Characters(i, 1).Font.Name
            Next
'Transfer to cell
'cell.value = mActiveTextBox.value

'Restore fonts
            If SelectionCount = 0 Then
            'do nothing
            End If
            If SelectionCount > 0 Then
                If cursorplaceholder > 1 Then
                    For i = 1 To cursorplaceholder - 1
                    cell.Characters(i, 1).Font.Name = fontarray(i - 1)
                    Next
                    For i = cursorplaceholder + SelectionCount - SelectionCount To Len(cell) - SelectionCount
                    cell.Characters(i, 1).Font.Name = fontarray(i - 1 + SelectionCount)
                    Next
                End If
            End If
                End With
            End If
        index = index + 1
        End If
        Application.ScreenUpdating = True
        Next
End Sub

'EXIT
Private Sub ButtonExit_Click()
    Unload Me
End Sub

'TERMINATE
Private Sub UserForm_Terminate()
    Dim Box As MSForms.TextBox
    Dim index As Long
    For index = TextBoxes.Count To 1 Step -1
        Me.TextBoxFrame.Controls.Remove TextBoxes(index).TextBoxGo.Name
        TextBoxes.Remove index
    Next
    Set TextBoxes = Nothing
    Set MyApplication = Nothing
End Sub

This is creating an event, which is a good step forward.

Is it possible to relay the "character typed" information to the Sub in the form code?

I've tried to delete a selected portion of text with "KeyDown". It doesn't work.
There seems to be a lag of one event. Pressing the second time shows the result for the first time, pressing for the third time shows the result for the second time, and so on.
When I say it doesn't work, the selected string characters are not deleted, but the fonts are changed though.

Private Sub MyTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 8 Or KeyCode = 46 Then
        Call UserFormFormulas.transfertwoLess(MyTextBox.SelLength)
    End If
End Sub

I've tried the suggestion at post #6 by passing the argument into the Sub (with "KeyDown"). I can't make it update in the Sub though.
I did try "KeyUp" yesterday but this does not store the value of the SelectionCount, the number of selected characters. This was one of the other requirements which allowed the ability to type over a selected number of characters.
"KeyPress" (when combined with MyTextBox_Change()) did update and restore fonts but unfortunately does not handle Delete.
A summary is shown below.

With the suggestion at post #7, the intention is to actually to implement the BackSpace and Delete, not prevent it.

See attached workbook for latest working.

Attachment 643760

I've progressed this somewhat over a lengthy period.
It's getting closer but still baffles.

First, to explain the theme:
The order of events is "KeyDown", "Change" of textbox, then "KeyUp". Public declarations are used to relay information between the three.

KeyDown is required to capture the instance where a selection is made (highlight a number of characters and type over them). "Change" of textbox is used to transfer contents to cell, from which a new array of characters is manipulated. "KeyUp" is required since it handles Backspace and Delete and captures the event after the textbox change. This took me days to figure out ... using Debug.Print window.

The code still does not work in instances such as Backspace and Delete. I can understand the details of what's happening however it still baffles me why the fonts are not restored correctly. The algorithm formulas look correct.

Any further suggestions?

CLASS MODULE (Part)

Private Sub MyTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
        Call UserFormFormulas.TransferKeyDown(MyTextBox.SelLength, KeyCode)
End Sub

Private Sub MyTextBox_Change()
    Call UserFormFormulas.TransferBoxChange(MyTextBox.SelLength)
End Sub


Private Sub MyTextBox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next 'Important
    Call UserFormFormulas.TransferKeyUp(MyTextBox.SelLength, KeyCode)
End Sub

FORM CODE (Part)

'(1)
Sub TransferKeyDown(SelectionCount As Long, ByVal KeyCode As MSForms.ReturnInteger)

Debug.Print "(1) KEY_DOWN"
Debug.Print "Selection = " & SelectionCount & ", " & "Code = " & KeyCode & ", " & "Letter = " & Chr(KeyCode)

    Dim TextBox As MSForms.TextBox
    Dim cell As Range
    Dim CursorLocation As Long
    Dim characterarray() As String
    Dim index As Long
    Dim i As Long, j As Long
    index = 1

    KeyPressed = KeyCode 'Used in KeyUp
    SelectionCountHold = SelectionCount

    For Each cell In MyApplication.Selection
        If Not IsEmpty(cell) Then
            If TextBoxes(index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
                    CursorLocation = .SelStart
                    cursorHolder = CursorLocation
                    
Debug.Print "Cursor = " & cursorHolder

                    ReDim characterarray(Len(cell) - 1)
                    ReDim fontarray(Len(cell) - 1)
                    For i = 1 To Len(cell)
                        characterarray(i - 1) = Mid$(cell, i, 1)
                        fontarray(i - 1) = cell.Characters(i, 1).Font.Name
                    Next
                    
            fontarrayOrig = fontarray 'Required when changing fonts in KeyUp
                 
Debug.Print "Length of cell = " & Len(cell)
'Debug.Print "Text = " & Join(characterarray, "")
Debug.Print Join(fontarray, ", ")
                   
                End With
            End If
        index = index + 1
        End If
    Next
    
Debug.Print "------------------------------------------------------------------"

End Sub


'(2)
Sub TransferBoxChange(SelectionCount As Long)

Debug.Print "(2) TEXTBOX CHANGE"
Debug.Print "Selection = " & SelectionCountHold

    Dim TextBox As MSForms.TextBox
    Dim cell As Range
    Dim characterarray() As String
    Dim index As Long
    Dim i As Long, j As Long
    index = 1
    For Each cell In MyApplication.Selection
        If Not IsEmpty(cell) Then
            If TextBoxes(index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
                    
Debug.Print "Cursor = " & cursorHolder

                    ReDim characterarray(Len(cell) - 1)
                    ReDim fontarray(Len(cell) - 1)
                    For i = 1 To Len(cell)
                        characterarray(i - 1) = Mid$(cell, i, 1)
                        fontarray(i - 1) = cell.Characters(i, 1).Font.Name
                    Next
        
    '''Transfer to cell
    '''Use in Debug.Print if required as a guide
    '''Turn off to make it work when there is just a cursor, no selection
        'cell.value = mActiveTextBox.value
                    
Debug.Print "Length of cell = " & Len(cell)
'Debug.Print "Text = " & Join(characterarray, "")
Debug.Print Join(fontarray, ", ")

                End With
            End If
        index = index + 1
        End If
    Next

Debug.Print "------------------------------------------------------------------"

End Sub


'(3)
Sub TransferKeyUp(SelectionCount As Long, ByVal KeyCode As MSForms.ReturnInteger)

Debug.Print "(3) KEY_UP"
Debug.Print "Selection = " & SelectionCountHold & ", " & "Code = " & KeyCode & ", " & "Letter = " & Chr(KeyCode)

    Dim TextBox As MSForms.TextBox
    Dim cell As Range
    Dim CursorLocation As Long, cursorplaceholder As Long
    Dim characterarray() As String
    Dim fontarray() As String
    Dim index As Long
    Dim i As Long, j As Long
    index = 1

    For Each cell In MyApplication.Selection
        If Not IsEmpty(cell) Then
            If TextBoxes(index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
                    CursorLocation = .SelStart
                    cursorplaceholder = CursorLocation
Debug.Print "Cursor = " & cursorHolder
                    
                    ReDim characterarray(Len(cell) - 1)
                    ReDim fontarray(Len(cell) - 1)
                    For i = 1 To Len(cell)
                        characterarray(i - 1) = Mid$(cell, i, 1)
                        fontarray(i - 1) = cell.Characters(i, 1).Font.Name
                    Next
                    
                    'Transfer to cell
                    cell.value = mActiveTextBox.value
                    
'########################################################################################
'RESTORE FONTS

'If Backspace or Delete
If KeyPressed = 8 Or KeyPressed = 46 Then
    For i = 1 To cursorHolder
        cell.Characters(i, 1).Font.Name = fontarrayOrig(i - 1)
    Next
    For i = cursorHolder + 1 To Len(cell)
        cell.Characters(i, 1).Font.Name = fontarrayOrig(i - 1 + SelectionCount)
    Next
End If
          
'If No Backspace or Delete (Typical)
If KeyPressed <> 8 And KeyPressed <> 46 Then
    'If SelectionCountHold = 0 (cursor only, no selection)
    If SelectionCountHold = 0 Then
        If cursorplaceholder = 1 Then
            cell.Characters(1, 1).Font.Name = fontarray(0)
            For i = cursorplaceholder + 1 To Len(cell)
                cell.Characters(i, 1).Font.Name = fontarray(i - 2)
            Next
        End If
        If cursorplaceholder > 1 Then
            For i = 1 To cursorplaceholder - 1
                cell.Characters(i, 1).Font.Name = fontarray(i - 1)
            Next
            For i = cursorplaceholder To Len(cell)
                cell.Characters(i, 1).Font.Name = fontarray(i - 2)
            Next
        End If
    End If
    'If SelectionCountHold = 1
    If SelectionCountHold = 1 Then
        For i = 1 To Len(cell)
            cell.Characters(i, 1).Font.Name = fontarrayOrig(i - 0)
        Next
    End If
    'If SelectionCountHold > 1
    If SelectionCountHold > 1 Then
        For i = 1 To cursorHolder + 1
            cell.Characters(i, 1).Font.Name = fontarrayOrig(i - 1)
        Next
        For i = cursorHolder + 2 To Len(cell)
            cell.Characters(i, 1).Font.Name = fontarrayOrig(i + SelectionCount)
        Next
    End If
End If
'########################################################################################
                     
                    ReDim fontarray(Len(cell) - 1)
                    For i = 1 To Len(cell)
                        fontarray(i - 1) = cell.Characters(i, 1).Font.Name
                    Next
                                  
Debug.Print "Length of cell = " & Len(cell)
'Debug.Print "Text = " & Join(characterarray, "")
Debug.Print Join(fontarrayOrig, ", ")
Debug.Print Join(fontarray, ", ")

                End With
            End If
        index = index + 1
        End If
    Next

Debug.Print "------------------------------------------------------------------"

End Sub

@AlphaFrog
The code is much simpler and intuitive. I've tested with no selection (cursor only) and this works. It will need a tweak when there is a selection in the text box. It also accounts for Navigation keys (non text), which was another part I had to add to stop errors.
Thanks for assisting.

Incidentally with the code at post #9, the error for Backspace or Delete was due to the following:
"SelectionCount" should have been "SelectionCountHold"