Excel VBA弹出形状

编程问答 2022-06-08

问题描述

我的Excel应用程序在加载和保存文件时需要弹出屏幕。我创建了一个宏，如下所示以弹出形状。最初，oShape.Top位置在当前屏幕下方，为300。

我尝试了宏的所有组合，并且无法使此椭圆形在当前屏幕上可见。奇怪的是，如果我在此宏的最后一个“ DoEvents”上创建调试切换断点，则弹出窗口将可见。

任何帮助将不胜感激。宏如下：

Public Sub TestUP()
    Dim oShape As Shape
    Set oShape = ActiveSheet.Shape("Oal42")
    Application.ScreenUpdating = True
    DoEvents
    NextTime = Now + TimeValue("00:00:05")
    oShape.Visible = True
    oShape.Top = 80
    DoEvents
    NextTime = Now + TimeValue("00"00"05")
    DoEvents
End Sub

解决方法

您的主要问题是，在您显示某个形状时就不会对其进行重新粉刷，并且当您发出DoEvent时，它似乎甚至也没有被粉刷。对于UserForm，有一种Repaint方法可以强制VBA重新显示它，但对于图纸或形状则不能。

但是，有一些技巧可以做到这一点。 This answer显示3种可能的骇客。我尝试了Application.WindowState = Application.WindowState，它对我有用。下面的代码提供了一个示例，说明了如何使用它-您可以在运行时修改文本。

Option Explicit
Const ShapeName = "Oal42"

Public Sub ShowMsg(msg As String)
    With ActiveSheet.Shapes(ShapeName)

        If .TextFrame2.TextRange.Characters <> msg Then
            .TextFrame2.TextRange.Delete
            .TextFrame2.TextRange.Characters = msg
        End If
          
        .Visible = True
        .Top = 80
        DoEvents
        Application.WindowState = Application.WindowState
    End With
End Sub

Public Sub HideMsg()
    ActiveSheet.Shapes(ShapeName).Visible = False
End Sub

显示用法：

Sub testSub()
    ShowMsg "Start"
    Dim i As Long
    For i = 1 To 100 Step 8
        ShowMsg "Working," & i & "%  done."
        Application.Wait Now + TimeSerial(0,1)
    Next i
    HideMsg 
End Sub
excelexcelpopupshapesvba