Flickering

[cyrus]

I know someone addressed this before, but I can't find it.
I'm inserting pictures based on cell contents. The code works great but
produces a lot of flickering. here is the code:
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
With wks
Select Case LCase(.Name)
Case Is = "cover"
'do nothing
Case Else
.Select

.Range("A218").Select
If .Range("B25") <> "" Then
.Unprotect
sName = .Range("A46").Text
.Pictures.Insert(sName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 216#
Selection.ShapeRange.Width = 288#
Selection.ShapeRange.Rotation = 0#
.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
Else
End If
Range("E2:H2").Select
If .Range("E25") <> "" Then
.Unprotect
sName = .Range("A47").Text
.Pictures.Insert(sName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 216#
Selection.ShapeRange.Width = 288#
Selection.ShapeRange.Rotation = 0#
.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
Else
End If
Range("I2:L18").Select
If .Range("H25") <> "" Then
.Unprotect
sName = .Range("A48").Text
.Pictures.Insert(sName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 216#
Selection.ShapeRange.Width = 288#
Selection.ShapeRange.Rotation = 0#
.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
Else
End If
End Select
End With
Next wks
Can some help

Thanks,

 

[NickHK]

Because you are inserting the full size picture then resizing, flicker will
occur.
Adding a Application.ScreenUpdating=False/True around your code may help.

Alternatively you can use this, which resizes prior to the insert:

With Range("D5")
ActiveSheet.Shapes.AddPicture .Range("A46").Text, False, True, .Left,
..Top, .Width, .Height
End With

Adjust the dimensions to suit. Check the for the meaning of the True & False
arguments.

Also, you only to .Unprotect at the beginning and .Protect at the end, not
each time.

NickHK

 

[Tom Ogilvy]

Have you put application.ScreenUpdating = False at the top and
Application.ScreenUpdating = True at the bottom.

That said, if you change the appearance of the screen by putting in a
picture, the screen is going to change.

 

[cyrus]

Nick and Tom,

Just wanted to let you guys know that your suggestions made it run 10 times
better.
I also moved my range selection after the IF statement. No need to select
anything if the conditions are not going to be met.
Thanks,