Userform textbox, account for Backspace and Delete

**Un-Do Re-Do** · 10-02-2019, 05:01 AM

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