MSO Add Shape Bug XL2007 +, comes up after Pop up.

[Doc.AElstein]

After MSO shape add, need a Wait before a Pop up, or it comes up after Pop up (XL 2007 2010 - don't need to wait in Excel 2003)

Happy Easter, Eileen’s Lounge :) ;)

I have a workaround to this problem that is OK. But I thought I would just ask if anyone knows how to do it properly.

I have a File.
Every day that File is opened by someone.
When they do that, and if they enable macros, then a few Pop ups come up and ask for some information.

I added today a few code lines to:
_ add a shape before a Pop up comes up ,
and to
_ delete it after the Pop up is closed.

But usually the shape will not come up until after the Pop up closes.
( So far I have experienced this in all Excel 2007 and 2010 versions that I have tried ).
The shape is then seen for only a split second just before the code line that deletes it.
( Strangely: if I add a 10 second wait after the Pop up, before the delete code line, then the shape still only comes up for a split second at the end of the 10 second wait, just before the code line that deletes it )

The workaround is to add a 1 second wait before the Pop up comes up.

Below and in the attached File is a code to demo the problem.
If you ‘comment out this code ,line which is just before the Pop up:_..

Code: Select all

    If CLng(Val(Application.Version)) <> 11 Then Application.Wait (Now + TimeValue("00:00:01")) ' Worksarounds for Excel 2007, 2010

_.., then typically you will only see the shape for a split second before it is deleted. ( At least that is my experience so far in Excel 2007 and 1010 )

I want the shape to stay up until the Pop up closes.
HappyEasterEileensLounge.JPG : https://imgur.com/dWedCzN" onclick="window.open(this.href);return false;

HappyEasterEileensLounge.JPG

My desires are satisfied within Excel 2007 and 2010 with the inclusion of a short wait before the Pop up, i.e. the inclusion of that code line above. But that seems a “bodge” / workaround to me, so I was wondering if anyone knows how to do it properly .
I tried this out on a few computers and Excel versions. I always seem to need the workaround in Excel 2007 and Excel 2010. I do not seem to need the workaround on any versions of Excel 2003 that I have tried.

This is not a major problem, but I thought I would ask on the off chance that anyone has any ideas to explain this strange behaviour and/ or knows a way to make sure the shape comes up before the Pop up, without my workaround.

Thanks
Alan

Demo Code:
( The main code, Pubic Sub Workbook_Open(), I normally have in in the ThisWorksheet code Modul, so that the code runs when the The Workbook is opened (You can run it from there or any other code module using the other code, Sub CallWorkbook_Open , below ))

Code: Select all

Option Explicit
' This code can go in any code module
Sub CallWorkbook_Open()
 Call ThisWorkbook.Workbook_Open
End Sub
'
'
'

' This code needs to go in the  ThisWorkbook  code module
Public Sub Workbook_Open() ' Bring up a shape before a Pop up box
 On Error GoTo Bed
Dim Shp As Shape: Set Shp = Worksheets.Item(1).Shapes.AddShape(msoShapeHeart, 50, 50, 200, 200)
    With Shp
     .Fill.ForeColor.RGB = RGB(240, 100, 230)
     .TextFrame.Characters.Text = "Happy" & vbCrLf & "Easter" & vbCrLf & Format(Date, "dddd") & vbCrLf & "Eileen's Lounge" & vbCrLf & "You secret hidden little Wild thing, you, x ;)"
     .TextFrame.HorizontalAlignment = xlHAlignCenter
     .TextFrame.Characters.Font.Color = vbWhite
        If CLng(Val(Application.Version)) = 11 Then ' Excel 2003
         .TextFrame.Characters.Font.Size = 15
         .TextFrame.Characters(8, 6).Font.Color = vbYellow
         .TextFrame.Characters(8, 6).Font.Size = 26
        Else ' Excel 2007 and Excel 2010 as far as I know
         .TextFrame.Characters.Font.Size = 14
         .TextFrame.Characters(7, 6).Font.Color = vbYellow
         .TextFrame.Characters(7, 6).Font.Size = 20
        End If
    End With
' DoEvents ' --- This line didn't have any effect on the problem
    If CLng(Val(Application.Version)) <> 11 Then Application.Wait (Now + TimeValue("00:00:01")) ' Worksarounds for Excel 2007, 2010
Dim strDte As String: Let strDte = VBA.InputBox(Prompt:="Date of pro", Title:="Give date to add to Filename", Default:=Replace((Format(Date, "dddd dd mmmm dd mm yyyy")), "ä", "ae", 1, 1, vbBinaryCompare))
' Application.Wait (Now + TimeValue("00:00:10")) ' Strangely: With this the shape is only there for a split second after the 10 second wait
 Shp.Delete
Exit Sub
Bed:
 MsgBox Prompt:=Err.Number & vbCrLf & Err.Description
    If Worksheets.Item(1).Shapes.Count = 1 Then Shp.Delete
 Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
End Sub

[HansV]

You could use Application.OnTime instead of Application.Wait:

In ThisWorkbook:

Code: Select all

Public Sub Workbook_Open() ' Bring up a shape before a Pop up box
    Dim strDte As String
    On Error GoTo Bed
    Set Shp = Worksheets.Item(1).Shapes.AddShape(msoShapeHeart, 50, 50, 200, 200)
    With Shp
     .Fill.ForeColor.RGB = RGB(240, 100, 230)
     .TextFrame.Characters.Text = "Happy" & vbCrLf & "Easter" & vbCrLf & _
         Format(Date, "dddd") & vbCrLf & "Eileen's Lounge" & vbCrLf & _
         "You secret hidden little Wild thing, you, x ;)"
     .TextFrame.HorizontalAlignment = xlHAlignCenter
     .TextFrame.Characters.Font.Color = vbWhite
        If CLng(Val(Application.Version)) = 11 Then ' Excel 2003
         .TextFrame.Characters.Font.Size = 15
         .TextFrame.Characters(8, 6).Font.Color = vbYellow
         .TextFrame.Characters(8, 6).Font.Size = 26
        Else ' Excel 2007 and Excel 2010 as far as I know
         .TextFrame.Characters.Font.Size = 14
         .TextFrame.Characters(7, 6).Font.Color = vbYellow
         .TextFrame.Characters(7, 6).Font.Size = 20
        End If
    End With
    Application.OnTime Now + TimeSerial(0, 0, 10), "DeleteShape"
    strDte = VBA.InputBox(Prompt:="Date of pro", Title:="Give date to add to Filename", _
        Default:=Replace((Format(Date, "dddd dd mmmm dd mm yyyy")), "ä", "ae"))
    Exit Sub
Bed:
    MsgBox Prompt:=Err.Number & vbCrLf & Err.Description
    If Worksheets.Item(1).Shapes.Count = 1 Then Shp.Delete
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

In a standard module:

Code: Select all

Public Shp As Shape

Sub DeleteShape()
    Shp.Delete
End Sub

[Doc.AElstein]

Thanks Hans
That looks like a much better way to do it.
It is also a bonus of having the shape up a little longer.

Strangely , with your code, the Pop up also comes up straight away and does not appear to exhibit the strange Phenomenon that my code did in Excel 2007 and Excel 2010. ( I have tested your code now on a few computers with Excel 2003, 2007 and 2010. It works in all cases )
( I expect possibly the strange phenomena that I noticed could be a Bug? – I cannot see why it should happen. ( – It does not happen by the way if you run the code in Debug ( F8 ) mode. ) )

I would never of come up with your idea as I mistakenly thought that you cannot have two codes running simultaneously. ( - Whenever I have used a code to set up a Application.OnTime , then the code setting it up has always finished before the one started with the Application.OnTime. )

This new possibility has my mind thinking up some new ideas that could work very well in my application. I am sure I will be able to make real mess of things going on all over the place at different times.

Also I spent a lot of time with API stuff recently to get a “pseudo” non model message box ( https://stackoverflow.com/questions/132 ... 8#48704228" onclick="window.open(this.href);return false; ) - This might be another way to look at that.

I was in two minds whether to post this question as my work around worked well.
But I am glad I did now.

Thanks again…
Happy Easter Hans
Alan




_...________________

Edit: A bit later ..
_1) I think I was talking rubbish… You can’t have more than one code running at once..
.. I noticed that the 10 seconds in Hans code starts from after the code finishes, so the Sub DeleteShape() is scheduled to start 10 seconds after the end of the sub in which it is scheduled..and if I have another code running at the time that the Sub DeleteShape() is scheduled to start then it doesn’t start - it waits until that current running code is finished.
_2) I expect my original problem is just some strange Bug: Depending on what you do before the pop up call, the bug may or may not occur
With Application.OnTime before the pop up the bug does not occur.
With many other things before the pop up call the bug does not occur… for example , ActiveSheet.Activate , Application.ScreenUpdating = True , Worksheets(1).Name = Worksheets(1).Name , ActiveCell.Select ….etc.. etc.. In fact almost anything “clears” the bug or stops it from happening….

But I still like the idea of messing about with Application.OnTime … :)

[Doc.AElstein]

This is just a short clarifying post as I think I confused the issue in my last post.

The issue:
There appears to be a bug in Excel 2007 and 2010, ( I would take a guess that it is in later versions also. The bug doesn’t appear to be in Excel 2003 )

The Bug
If a shape is added before a Pop up call then it won’t come up until after the Pop up call

The Not workaround
I mistakenly thought that it was a time issue, and that waiting a while before bringing the Pop up was the workaround.
On further experimenting that appears not to be the case:
_ In the first code below, Sub BugXL2007PlusShapeWontComeBeforePopUp() , I have a loop after the Add of a shape and before a Pop up call. That loop takes quite a while on my computers. Never the less, the shape first comes up after the Pop up is closed
_ Also I have a line, Cells.Value = Cells.Value after the Add of a shape and before a Pop up call. That code line takes a long time on my computers, but still the shape comes up after the Pop up

The Workarounds
It seems that the inclusion of various code lines after the Add of the shape and before Pop up call will prevent the bug.
In the workaround codes below are a few example of ways to prevent the bug with a code line in between but there appear to be very many.
The Application.Wait and Application.OnTime are coincidentally also amongst the very many code lines which prevent the bug when these code lines are added after the shape Add and before the Pop up call.
But it is the code line use itself which seems to prevent the bug, and not the delay it adds.... _..
-.. so even code lines of
Application.Wait Now
or
Application.OnTime Now, “Anycode”
, will prevent the bug.


( But the Application.OnTime to schedule a code to delete the shape after a while is a nice idea anyway, so I will probably use that ).

Alan

P.s. I have often found that activating the active worksheet, or selecting a cell has often cleared strange inconstant problems with VBA codes. So as a “belt and braces” solution I will probably use Han’s code along with an extra ActiveSheet.Select, or similar code line, just before the Pop up. ( Codes lines of that sort are typically amoungst those which seem to prevent the bug which is discussed in this Thread)

Ps.2 Once in a while the shape does come up unexpectedly before a Pop up in the codes where that usually does not happen

P.s.3 There still seems to be no issue in Excel 2003
_.____

These simple demo codes can go in any module except that called by Application.Ontime which should go in a normal code module

Code: Select all

 '     http://www.eileenslounge.com/viewtopic.php?f=30&t=29579&sid=53a575cc9c96079a8be7f35f04799271#p228877

Public Posx As Long

Sub BugXL2007PlusShapeWontComeBeforePopUp() '( In these code you usually never see the love, or just see it for a split second )
 LuvUEL ' Function to love Eileen's Lounge
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
'
Dim Cnt As Long, TotalCnt As Long
 LuvUEL
    For Cnt = 1 To 1000000000
     Let TotalCnt = TotalCnt + 1
    Next Cnt
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
'
 LuvUEL
    If 1 = 1 Then
    End If
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
'
 LuvUEL
 Range("A1").Value = ""
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
'
 LuvUEL
 MsgBox ""
 MsgBox ""
 MsgBox ""
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
'
 LuvUEL
 Cells.Value = Cells.Value
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
'
'_-  __________________-
'
' Workarounds of which there are many =========================
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds()
 LuvUEL
 ActiveSheet.Activate
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds2()
 LuvUEL
 Application.OnTime EarliestTime:=Now, procedure:="AnyFink"
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds3()
 LuvUEL
 Worksheets.Item(1).Name = Worksheets.Item(1).Name
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds4()
 LuvUEL
 Application.Wait Now ' The workaround is not the waiting but the use of this code line
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds5()
 LuvUEL
 Range("A1").Activate
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds6()
 LuvUEL
 Cells.Value = Cells.Value
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds7()
 LuvUEL
 ActiveSheet.Select
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkarounds8()
 LuvUEL
 ActiveCell.Select
 MsgBox ""
     If Worksheets.Item(1).Shapes.Count = 1 Then Worksheets.Item(1).Shapes.Item(1).Delete
End Sub
'
'_-_____________________
'  Function to spread Love =================================
Function LuvUEL() ' Function to love Eileen's Lounge
 Let Posx = Posx + 10 ' To help distinguish if we have more than one shape
    With Worksheets.Item(1).Shapes.AddShape(msoShapeHeart, 50 + Posx, 50, 200, 200)
     .Fill.ForeColor.RGB = RGB(240, 100, 230)
     .TextFrame.Characters.Text = "Happy" & vbCrLf & "Easter" & vbCrLf & Format(Date, "dddd") & vbCrLf & "Eileen's Lounge, x"
     .TextFrame.HorizontalAlignment = xlHAlignCenter
     .TextFrame.Characters.Font.Color = vbWhite
        If CLng(Val(Application.Version)) = 11 Then ' Excel 2003
         .TextFrame.Characters.Font.Size = 15
         .TextFrame.Characters(8, 6).Font.Color = vbYellow
         .TextFrame.Characters(8, 6).Font.Size = 26
        Else ' Excel 2007 and Excel 2010 as far as I know
         .TextFrame.Characters.Font.Size = 14
         .TextFrame.Characters(7, 6).Font.Color = vbYellow
         .TextFrame.Characters(7, 6).Font.Size = 20
        End If
    End With
End Function
'
'_-______________________________
'  A sub to be called by  Application.Ontime  at anytime =====
Sub AnyFink()
End Sub 

[Jan Karel Pieterse]

One workaround seems to be to add two DoEvents just prior to displaying the inputbox or message box.

[Doc.AElstein]

Thanks Jan, I had not noticed that one.
I had tried a single DoEvents but that had not worked. ( - I never quite understood what DoEvents was supposed to do: I never yet experienced it Doing any Event or Doing anything else. But It sounded like a good candidate for a workaround. I think I tried that first, but never thought to try it twice. )
I just checked it on a few Excel2007 and Excel2010 versions. The double DoEvents seems a consistent workaround.

Out of interest what version of Excel did you try??? I am guessing the problem is at Excel 2007 +
But I only have 2007 and 2010

_.________________

So anyway .. _...
_..DoEvents has the sound to it of what should work as a workaround.
_..I myself often noticed that activating something activated or selecting something selected often overcomes strange problems, in VBA ( – I am guessing possibly some strange Windows z order bug or something in the wrong place in some chain of events. .. Recently I delved into API stuff for the first to make my own Pop ups. I find then I often have to select what should already “be on the top” to actually make it appear on the top.
_.. I actually like the idea of the Application.OnTime to leave the thing up for a while..
So finally _....
This would be for now my belts and braces workaround. ….

Code: Select all

Dim Posx As Long
Public TotalCnt As Long
Sub BugXL2007PlusShapeWontComeBeforePopUpWorkaroundsPlus1() '  http://www.eileenslounge.com/viewtopic.php?f=30&t=29579#p229098
 Let TotalCnt = Worksheets.Item(1).Shapes.Count ' This works only sometomes to find the last added shape ??
 LuvUEL ' Function to love Eileen's Lounge at Easter
 DoEvents: DoEvents:  ActiveSheet.Activate: DoEvents: ActiveCell.Select: DoEvents: Application.OnTime EarliestTime:=Now + TimeSerial(0, 0, 7), procedure:="" & ThisWorkbook.FullName & "!" & "Modul1.DeleteShapePlus1": DoEvents: DoEvents 
 'MsgBox ""
Dim Rsel As Range
 Call HangAHookToCatchAPIssinUserDLL_MsgBoxThenBringThatMsgBoxUp(Rsel) ' API call Message Box Pop Up
End Sub
Sub DeleteShapePlus1()
   If Worksheets.Item(1).Shapes.Count = TotalCnt + 1 Then Worksheets.Item(1).Shapes.Item(TotalCnt + 1).Delete
End Sub











'_-_____________________
'  Function to spread Love =================================
Function LuvUEL() ' Function to love Eileen's Lounge
' Let Posx = Posx + 10 ' To help distinguish if we have more than one shape
    With Worksheets.Item(1).Shapes.AddShape(msoShapeHeart, 50 + Posx, 50, 200, 200)
     .Visible = True
     .Fill.ForeColor.RGB = RGB(240, 100, 230)
     .TextFrame.Characters.Text = "Happy" & vbCrLf & "Easter" & vbCrLf & Format(Date, "dddd") & vbCrLf & "Eileen's Lounge, x"
     .TextFrame.HorizontalAlignment = xlHAlignCenter
     .TextFrame.Characters.Font.Color = vbWhite
        If CLng(Val(Application.Version)) = 11 Then ' Excel 2003
         .TextFrame.Characters.Font.Size = 15
         .TextFrame.Characters(8, 6).Font.Color = vbYellow
         .TextFrame.Characters(8, 6).Font.Size = 26
        Else ' Excel 2007 and Excel 2010 as far as I know
         .TextFrame.Characters.Font.Size = 14
         .TextFrame.Characters(7, 6).Font.Color = vbYellow
         .TextFrame.Characters(7, 6).Font.Size = 20
        End If
    End With
End Function

Thanks again for the replies
Alan

[Jan Karel Pieterse]

I just happened on a very similar post somewhere else which described an identical problem with Excel 2016. Two DoEvents solved it for 2016. DOEVents tells VBA/Excel to wait for the operating system to finish handling all events. Or so I was told :-)

[Doc.AElstein]

Thanks Jan, I had heard something similar about what DoEvents did, but hadn't ever "experienced" it doing anything...
:)