controlling image generation in a Visio drawing

I am an experienced Excel VBA coder and have done a little Word VBA but am totally new to Visio VBA.  My project opens an Excel file that contains the file names of images.  It also contains the X, Y, Width, and Height for each image inserted into a Visio drawing 36 x 48.  Each image has a solid line border 12pts wide with square corners.  Pin Pos is Top-Left for all. 

The code opens Excel and reads the file names and variables for each image (called cards) into arrays.  It closes Excel and then inserts the images in a 6 row 7 column drawing using the following procedure.  I constructed it using the recorder and then adjusted it to the arrays.  Im sure it is not elegant but it works fine except there is about a 4 second delay before the images appear even though the procedure only takes 1.7 seconds to complete (found using the timer).

Private Sub insert_cards()
    Dim start As Single, sstop As Single
    Dim r As Long, c As Long, indx As Long
    Dim shpImg As Visio.Shape
    Dim UndoScopeID1 As Long
    Dim UndoScopeID2 As Long
    Dim UndoScopeID6 As Long
    Dim endUndoScopeID2 As Long
    start = Timer
    For r = 0 To 5
        For c = 0 To 6
            indx = (r * 7) + c + 1 'indx runs from 1 to 42 not 0 to 41
            UndoScopeID1 = Application.BeginUndoScope("Insert")
            Set shpImg = ActiveWindow.Page.Import(CardPath & CardNames(indx))
            UndoScopeID2 = Application.BeginUndoScope("Size & Position 2-D")
            With shpImg
                .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = CXA(c) & "pt"
                .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = RYA(r) & "pt"
                .CellsSRC(visSectionObject, visRowXFormOut, visXFormLocPinX).FormulaU = "Width*0"
                .CellsSRC(visSectionObject, visRowXFormOut, visXFormLocPinY).FormulaU = "Height*1"
                .CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = WA(c) & "pt"
                .CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = H & "pt"
                UndoScopeID6 = Application.BeginUndoScope("Line Style")
                .CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = "THEMEGUARD(RGB(0,0,0))"
                .CellsSRC(visSectionObject, visRowLine, visLinePattern).FormulaU = "1"
                .CellsSRC(visSectionObject, visRowGradientProperties, visLineGradientEnabled).FormulaU = "FALSE"
                .CellsSRC(visSectionObject, visRowLine, visLineWeight).FormulaU = "12 pt"
                .CellsSRC(visSectionObject, visRowLine, visLineEndCap).FormulaU = "2"
            End With
        Next
    Next
    sstop = Timer - start
    endUndoScopeID2 = Application.BeginUndoScope("Home")
End Sub

I would like the images to appear a row at a time so the user sees action rather than 4 seconds of no action.  The last image is still selected at the end which would be nice to fix as well. 

I think this must be simple to do.  ScreenUpdating did not seem to do anything.  Any help or links pointing me in the right direction would be most apprec

June 11th, 2015 12:25pm

To improve performance, don't set cells individually, set them in batch.

I.e. don't use .CellsSRC().FormulaU, use .SetFormulas instead.

This will speed up things significantly.

To show users how Visio redraws the screen, try using good old DoEvents in the cycle.

More performance tips:
http://blogs.msdn.com/b/mailant/archive/2004/09/22/233082.aspx
http://blogs.msdn.com/b/wmorein/archive/2007/11/13/solution-performance-tip-1-getformulas-and-setformulas.aspx
https://msdn.microsoft.com/en-us/library/office/aa176886

Free Windows Admin Tool Kit Click here and download it now
June 11th, 2015 12:58pm

Nikolay,

Thanks for your reply.  This is what i was looking for.  I will implement your suggestions.  

The DoEvents did the trick in getting the rows to show up one at a time.

Thanks again

June 11th, 2015 6:39pm

This topic is archived. No further replies will be accepted.

Other recent topics Other recent topics