【Excel VBA编程】给Excel装上“放大镜”,让单元格内文字变大变清晰

#If VBA7 Then    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long#Else    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long#End IfPrivate Type POINTAPI    X As Long    Y As LongEnd Type' 声明必要的API函数，用于延时#If VBA7 Then    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)#Else    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)#End If

 Sub MainPro()    Dim endTime As Double    Dim durationSeconds As Long    Dim shp As Shape    On Error Resume Next    Set shp = ActiveSheet.Shapes("MyLabel")    On Error GoTo 0    If shp Is Nothing Then        ' 创建放大镜形状        Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 0, 0, 200, 80)        shp.Name = "MyLabel"        With shp.TextFrame2            .VerticalAnchor = msoAnchorMiddle            .TextRange.Font.Size = 24 ' 设置放大字体            .TextRange.Font.NameComplexScript = "隶书"            .TextRange.Font.Name = "隶书"            .TextRange.Font.NameFarEast = "隶书"            .TextRange.Font.Bold = msoTrue            .TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) '字体颜色        End With        'shp.Fill.ForeColor.RGB = RGB(255, 250, 235) ' 设置背景色        shp.Line.ForeColor.RGB = RGB(255, 245, 215) ' 设置边框        shp.Visible = msoFalse ' 初始隐藏        With shp.Fill            .ForeColor.RGB = RGB(255, 230, 160) '渐变效果，深到浅            .OneColorGradient msoGradientHorizontal, 1, 0.5            .GradientStops.Insert RGB(255, 250, 235), 0.5 ' 在中间位置添加过渡色,淡        End With    End If    durationSeconds = 20 ' 设置时长（秒）    endTime = Timer + durationSeconds    Do While Timer < endTime        Sleep 2000  '暂停2秒        Call MagnifyingByMouse(shp)  ' 调用函数        DoEvents ' 转让控制权，避免程序无响应    Loop    MsgBox "放大效果结束。"End Sub

 Sub MagnifyingByMouse(shp As Shape)    Dim lppt As POINTAPI    Dim res As Long    Dim c As Range    ' 获取当前鼠标光标在屏幕上的位置    res = GetCursorPos(lppt)    ' 使用屏幕坐标，通过RangeFromPoint获取该点的对象    Set c = ActiveWindow.RangeFromPoint(lppt.X, lppt.Y)    ' 检查获取的对象是否为单元格，并选中它    If Not c Is Nothing Then        If TypeName(c) = "Range" Then            c.Select ' 选中该单元格            shp.TextFrame2.TextRange.Text = c.Value            ' 更新放大镜位置（例如，显示在单元格右下方）            shp.Left = c.Offset(0, 1).Left            shp.Top = c.Top            ' 显示放大镜            shp.Visible = msoTrue        Else            shp.Visible = msoFalse '隐藏放大镜        End If    End IfEnd Sub