Excel 为视力受损的用户放大单个单元格的内容

这项任务是编写一个程序，使单个单元格中的字母非常大，并以最大的对比度显示出来，供视力受损的人使用。我写了这样一个程序，希望在下面我自己的答案中与大家分享。欢迎提出改进意见和建议，以及提交用于相同目的的程序的备选答案。

下面的代码将ActiveX文本框叠加在选定单元格上，其中单元格内容以放大格式显示。放大系数可以设置，背景色和前景色也可以设置，以控制对比度。用户使用箭头键、Enter键、Shift-Enter键、Tab键和Shift-Tab键从一个单元格导航到另一个单元格，或者用鼠标单击。F2启用公式的单元格内编辑（放大显示）。Ctl+M删除当前单元格中的文本框，Shift+Ctl+M通过将放大设置为零来结束程序

代码分为两部分。下文第1部分必须安装在标准代码模块中

Option Explicit

Private Const MagName   As String = "Magnus"

Sub SetMagnus()
    ' NIC 047 09 Jun 2020
    ' Use this procedure to set or modify the magnifying multiplier.
    ' Call it from the Macros button on the Developer tab
    ' or assign a keyboard shortcut to it.
    ' The multiplier can also be modified directly in the document properties.
    
    Dim Mag     As String
    
    Mag = InputBox("Enter the desired magnifying multiplier (< 1 - 8):", _
                   "Setting the MAGNUS property", "3")
    Magnum Val(Mag)
End Sub

Function Magnum(Optional ByVal Mag As Integer = -1) As Integer
    ' NIC 047 09 Jun 2020
    ' this function is a designed as a UDF to set or modify
    ' the magnifying multiplicator from the worksheet
    
    Dim Fun As Integer
    
    With ThisWorkbook
        On Error Resume Next
        If Not (Mag = True) Then
            ' maximum magnification permissible = +8x
            Fun = Application.Min(Abs(Int(Mag)), 8)
            .CustomDocumentProperties(MagName) = Fun
            If Err Then .CustomDocumentProperties.Add _
                         MagName, False, _
                         msoPropertyTypeNumber, Fun
        Else
            Fun = .CustomDocumentProperties(MagName)
            Fun = Application.Min(Abs(Int(Fun)), 8)
        End If
    End With
    
    Magnum = Fun
    Err.Clear
End Function

Sub SetTbx(Target As Range)
    ' NIC 047 21 Jun 2020
    
    ' Set the constant 'ColorScheme' to one of the following values:-
    ' ============================================================
    ' 2 = White font on purple ground
    ' 1 = Black font on white ground
    ' 0 = font and background colours follow the scheme in the underlying cell
    '     (This is also the default and will be used if the constant
    '      'ColorScheme' identifies a non-existent scheme)
    Const ColorScheme As Integer = 2
    ' ============================================================
    
    Dim Tbx         As OLEObject            ' the TextBox being created
    Dim BackColor   As Long                 ' background color
    Dim FontColor   As Long                 ' font color
    Dim Mag         As Integer              ' magnification multiplier
    
    
    ' To add another colour scheme (e.g. ColorScheme 3)
    ' ============================================================
    '   Add another 'Case' to the statement below, e.g "Case 3"
    '       add the new line directly above the line "Case Else"
    '   Copy a line pair 'BackColor' and 'ForeColor' from one of the
    '       other schemes and paste or type below the new line 'Case 3'
    '   Change the colour specifications in the new scheme.
    '       You can use VB constants, numeric values of Long data
    '       type or RGB functions.
    '   That's all. The new scheme can now be specified using the
    '       constant 'ColorScheme'
    '   Save the workbook to make the option permanent.
    '       The other options will still be available for future
    '       use by changing the value assigned to the constant.
    '       There is no need to remove any option once it has been
    '       created.
    ' ============================================================
    
    '   Finding colour numbers
    ' ============================================================
    '   1. Colour any cell in aany worksheet with the colour you want.
    '   2. Select the cell.
    '   3. Switch view to the VB Editor window (Alt+F11)
    '   4. In the Immediate pane (at the bottom of the screen)
    '      type "? Selection.Interior.Color"
    '   5. The number of the cell's colour will be displayed in the
    '      Immediate pane. It can be used to define BackColor or
    '      ForeColor in a ColorScheme.
    '   Note: "? Selection.Font.Color" will show the font's colour.
    '         "? RGB(128, 0, 128)" will show the number specified
    '         by the RGB function.
    ' ============================================================
    
    Select Case ColorScheme
        Case 1
            BackColor = vbWhite             ' = 16777215
            FontColor = vbBlack             ' = 0
        Case 2
            BackColor = RGB(128, 0, 128)    ' = 548545 (purple)
            FontColor = vbWhite             ' = 16777215
        Case Else
            With Target
                BackColor = .Interior.Color
                FontColor = .Font.Color
            End With
    End Select
    
    
    Mag = Magnum
    On Error Resume Next
    Set Tbx = ActiveSheet.OLEObjects(MagName)
    If Err Then
        Set Tbx = Target.Worksheet.OLEObjects _
                        .Add(ClassType:="Forms.TextBox.1", _
                             Link:=False, _
                             DisplayAsIcon:=False, _
                             Left:=100, Top:=100, _
                             Width:=100, Height:=20)
    End If
    
    On Error GoTo 0
    With Tbx
        With .Object
            .BackColor = BackColor
            .SpecialEffect = fmSpecialEffectFlat
            .BorderStyle = fmBorderStyleSingle
            .IntegralHeight = False
            .ForeColor = FontColor
            .Font.Size = Target.Font.Size * Mag
        End With
        .Left = Target.Left
        .Top = Target.Top
        .Width = Target.Width * Mag
        .Height = (Target.Offset(1).Top - .Top) * Mag
        .Name = MagName
        .LinkedCell = Target.Address
        .Activate
    End With
End Sub

Sub KillTbx(Optional Ws As Worksheet)
    ' NIC 047 09 Jun 2020

    Dim Tbx             As OLEObject        ' TextBox
    Dim LinkedCell      As Range            ' Cell linked to Tbx
    
    If Ws Is Nothing Then Set Ws = ActiveSheet
    On Error Resume Next
    Set Tbx = Ws.OLEObjects(MagName)
    If Err = 0 Then
        Set LinkedCell = Ws.Range(Tbx.LinkedCell)
        LinkedCell.Select
        Tbx.Delete
    End If
    Err.Clear
End Sub

Function KeyUpEvent(ByVal KeyCode As Integer, _
                    ByVal Shift As Integer) As Integer
    ' NIC 047 30 Jun 2020

    Dim Tbx         As OLEObject
    Dim n           As Long                 ' offset
    
    Set Tbx = ActiveSheet.OLEObjects(MagName)
    If KeyCode = 13 Then                    ' Enter
        If Tbx.LinkedCell = "" Then         ' Exit edit mode
            On Error Resume Next            ' in case of formula error
            Range(Tbx.TopLeftCell.Address).Formula = Tbx.Object.Value
            Tbx.LinkedCell = Tbx.TopLeftCell.Address
            On Error GoTo 0
            Exit Function
        Else
            KeyCode = IIf(Shift, 38, 40)    ' act like Up/Down arrow
        End If
    End If
    
    Select Case KeyCode
        Case 38, 40                         ' Up-arrow / Down-arrow
            n = IIf(KeyCode = 38, -1, 1)
            If ActiveCell.Row + n Then
                Range(Tbx.LinkedCell).Offset(n).Select
            End If
            KeyCode = 0
        Case 9                              ' tab
            n = IIf(Shift, -1, 1)
            If ActiveCell.Column + n Then
                Range(Tbx.LinkedCell).Offset(, n).Select
            End If
            KeyCode = 0
        Case 77                             ' Ctl + M (delete Tbx once)
            KillTbx
            If Shift = 3 Then Magnum 0      ' stop Magnus
            KeyCode = 0
        Case 113                            ' F2 (enabled in-cell editing)
            With Tbx
                If .LinkedCell <> "" Then
                    .Object.Value = Range(.LinkedCell).Formula
                    .LinkedCell = ""
                End If
            End With
            KeyCode = 0
    End Select
    
    KeyUpEvent = KeyCode
End Function

---

通过使用代码第1部分顶部描述的方法之一设置放大倍增器来启动使用。当乘数设置为零时，代码将保持或变为非活动状态。

不麻烦，但我很清楚，您拥有丰富的Excel VBA知识，我只是好奇您是否认为您能在我最近的问题上帮助我，因为我手头很紧，而且有点时间敏感性。谢谢。请在这里贴一个你的问题的链接，我会试试。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' NIC 047 09 Jun 2020

    If Magnum Then
        SetTbx Target.Cells(1)
    Else
        KillTbx ActiveSheet
    End If
End Sub

Private Sub Magnus_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, _
                         ByVal Shift As Integer)
    ' NIC 047 09 Jun 2020
    
    KeyCode = KeyUpEvent(KeyCode, Shift)
End Sub