2

I'm trying to get Visio to update the fill colour of each shape immediately after I change it.

I've tried using various methods - screenupdate, showchanges, sendkeys "%^g" but nothing works with the colour. Only changing the screen size by 0.01% forces the app to change the text, which is at least something.

I can step through the code and it works but when I run it none of the colours change until the end.

I'm changing the colour of each object using:

Application.ActiveWindow.Page.Shapes.ItemFromID(servshape(y - 1)).CellsU("Fillforegnd").FormulaU = "RGB(253, 190, 0)"

The code runs through a list of dates and changes the colour of the objects when required, problem is it only shows the changes at the end.

The loop through each item in the list is approximately one second, long enough to see any change. I was hoping there was a simple refresh command but that only seems to work with datarecordsets.

Is there any way of refreshing an object fill colour immediately after changing it?

Community
  • 1
  • 1
mattc123
  • 21
  • 2
  • Have you tried DoEvents? https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/doevents-function – L8n Jun 28 '19 at 16:43
  • Also, your code could be improved by doing a "For Each" Loop, using the ItemFromID is error-prone unless you know for sure the ID exists! Assigning the ActiveWindow/Page to a variable at the beginning of the code should also improve the stability if someone someone was to click "outside" the application at any point during execution. – L8n Jun 28 '19 at 16:47

1 Answers1

0

Should work with DoEvents:

Option Explicit

Sub reColorAll()
    Dim pg As Visio.Page
    'Set pg = Application.ActiveWindow.Page
    Set pg = ActivePage ' Probably what you want



    Dim shp As Visio.Shape
    For Each shp In pg.Shapes
        If True Then 'test if shape is one of the ones you want, replace true with test
            If shp.CellExistsU("Fillforegnd", False) Then 'test if cell even exists
                shp.CellsU("Fillforegnd").FormulaU = "RGB(253, 190, 0)"
                DoEvents' force Application to update
            End If

            'Timer to simulate delay, can be removed for your case
            Dim pauseTime As Long
            Dim start As Long
            pauseTime = 1   ' Set duration in seconds
            start = Timer    ' Set start time.
            Do While Timer < start + pauseTime
            Loop
            'End Timer Code

        End If
    Next shp

End Sub

Timer Source:

L8n
  • 728
  • 1
  • 5
  • 15
  • Great! thanks for your help, that works just fine, it was driving me mad! many thanks, Matt – mattc123 Jun 28 '19 at 18:31
  • @mattc123 No problem. Since this seems to solve your problem can mark the answer as accepted? – L8n Jun 28 '19 at 19:41