Transfer characters to cell by Userform

**Un-Do Re-Do** · 10-02-2020, 04:47 AM

The code below allows you to edit the contents of a cell by typing, and preserves the fonts when a character is typed.

The fonts are thrown out in the following two cases.
1. If you press several keys in quick succession (different characters).
2. If you press and hold a key.

I've tried counters and boolean expressions but these are not processed in logical order in the above two cases (for example, 2 KeyDown events are recorded followed by 2 KeyUp events ... instead of 1 Down, 1 Up, 1 Down, 1 Up).

The resolution so far is to use a Timer function, if a character is entered too quickly, then nothing happens.

I was wondering if there was another way instead of a Timer?

Call Sub

Option Explicit

Public TimeBetweenKeyStroke As Single

Sub FormCall()
    TimeBetweenKeyStroke = 0
'    TimeBetweenKeyStroke = 0.5
    UserForm1.Show vbModeless
End Sub

ClassTyping

Option Explicit

Private WithEvents TextBoxTyping As MSForms.TextBox

Dim TimeCurrent1 As Single, TimePrevious1 As Single, TimeCurrent2 As Single, TimePrevious2 As Single

Public Property Set Control(TextBoxTypingArgument As MSForms.TextBox)
    Set TextBoxTyping = TextBoxTypingArgument
    TimePrevious1 = Timer() - 1 'Allow for 1 second difference
    TimePrevious2 = Timer() - 1 'Allow for 1 second difference
End Property

Private Sub TextBoxTyping_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    TimeCurrent1 = Timer()
    If TimeCurrent1 - TimePrevious1 <= TimeBetweenKeyStroke Then
        KeyCode = vbNull
        Application.StatusBar = String(1, ChrW(&H275D)) & "TYPING TOO FAST" & String(1, ChrW(&H275E))
    End If
    If TimeCurrent1 - TimePrevious1 > TimeBetweenKeyStroke Then
        Call UserForm1.TransferAtKeyDown(KeyCode)
        Application.StatusBar = False 'Clear error message in status bar
    End If
    TimePrevious1 = TimeCurrent1
End Sub

Private Sub TextBoxTyping_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    TimeCurrent2 = Timer()
    If TimeCurrent2 - TimePrevious2 <= TimeBetweenKeyStroke Then
        KeyCode = vbNull
    End If
    If TimeCurrent2 - TimePrevious2 > TimeBetweenKeyStroke Then
        Call UserForm1.TransferAtKeyUp(KeyCode)
    End If
    TimePrevious2 = TimeCurrent2
End Sub

Form Code

Option Explicit

'General
Private WithEvents MyApplication As Excel.Application
Public WithEvents cDelegate As ClassDelegate
'Ranges
Dim Cell As Range
'Textboxes
Private TextBoxes As Collection
Private mActiveTextBox As MSForms.TextBox
Dim TextBox As MSForms.TextBox
'Form editing by Typing
Dim TextBoxCollection As Collection
Public CursorLocationStore As Long
Public FontArrayStore As Variant

'INITIALIZE
Private Sub UserForm_Initialize()
    Set cDelegate = New ClassDelegate
    Call FormCreation(True)
    Me.Top = Application.Top + 0.5 * Application.UsableHeight: Me.Left = Application.Left + 0.5 * Application.UsableWidth
    Call TypingControls
End Sub

'CREATE FORM
Private Sub FormCreation(BuildButtons As Boolean)
    Dim cEvents As ClassBoxes
    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 MyControl As MSForms.Control
    Dim Index As Long
    'Miscellaneous
    Set MyApplication = Application
    BoxHeight = 27: BoxTop = 0: BoxLeft = 0: BoxWidth = TextBoxFrame.Width: BoxGap = 0 'FormBoxHeight from Input module
    Index = 1
    If TextBoxes Is Nothing Then
        Set TextBoxes = New Collection
    End If
    'Create textboxes
        For Each Cell In Selection
            If Index > TextBoxes.Count Then
                Set cEvents = New ClassBoxes
                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
                .AutoWordSelect = False
                .Font = "Courier New"
                .Font.Size = 17
                .Text = Cell.Formula
            End With
            Index = Index + 1
            BoxTop = BoxTop + BoxHeight + BoxGap
        Next Cell
    'Remove extra textboxes
    Do While TextBoxes.Count > Index
        TextBoxes.Remove TextBoxes.Count
    Loop
    'Activate first textbox
    Set mActiveTextBox = Me.TextBoxFrame.TextBox1
End Sub

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

'CONTROLS FOR TYPED CHARACTERS
Private Sub TypingControls()
    Dim ctrl As MSForms.Control
    Dim obj As ClassTyping
    Set TextBoxCollection = New Collection
        For Each ctrl In Me.Controls
            If TypeOf ctrl Is MSForms.TextBox Then
                Set obj = New ClassTyping
                Set obj.Control = ctrl
                TextBoxCollection.Add obj
            End If
        Next ctrl
    Set obj = Nothing
End Sub

'------------------------------------
'INSERT & DELETE CHARACTERS BY TYPING
'------------------------------------

'AT KEY DOWN (stores value for number of selected characters)
Sub TransferAtKeyDown(ByVal KeyCode As MSForms.ReturnInteger)
    Dim Index As Long
    Dim i As Long
    On Error Resume Next
    Index = 1
        For Each Cell In Selection
            If TextBoxes(Index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox
                    If Not IsEmpty(Cell) Then
                        CursorLocationStore = .SelStart 'Used in KeyUp
                        ReDim FontArrayStore(Len(Cell) - 1)
                        For i = 1 To Len(Cell)
                            FontArrayStore(i - 1) = Cell.Characters(i, 1).Font.Name 'Used in KeyUp
                        Next
                    End If
                End With
            End If
        Index = Index + 1
        Next Cell
End Sub

'AT KEY UP (required to handle Backspace and Delete)
Sub TransferAtKeyUp(ByVal KeyCode As MSForms.ReturnInteger)
    Dim Index As Long
    Dim i As Long
    On Error Resume Next
    Index = 1
        For Each Cell In Selection
            If TextBoxes(Index).TextBoxGo.Name = mActiveTextBox.Name Then
                With mActiveTextBox 'Transfer to cell and restore fonts
                    Cell.value = mActiveTextBox.value
                    'Backspace
                    If KeyCode = 8 Then
                        For i = 1 To CursorLocationStore - 1
                            Cell.Characters(i, 1).Font.Name = FontArrayStore(i - 1)
                        Next
                        For i = CursorLocationStore To Len(Cell)
                            Cell.Characters(i, 1).Font.Name = FontArrayStore(i)
                        Next
                    End If
                    'Typical
                    If KeyCode <> 8 Then
                        For i = 1 To CursorLocationStore - 0
                            Cell.Characters(i, 1).Font.Name = FontArrayStore(i - 1)
                        Next
                        For i = CursorLocationStore + 1 To Len(Cell)
                            Cell.Characters(i, 1).Font.Name = FontArrayStore(i - 2)
                        Next
                    End If
                End With
            End If
        Index = Index + 1
        Next Cell
End Sub

'EXIT
Private Sub ButtonExit_Click()
    Unload Me
End Sub

'TERMINATE
Private Sub UserForm_Terminate()
    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