|
Flickering
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("A2:D18").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, -- CY |
Flickering
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 "cyrus" wrote in message ... 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("A2:D18").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, -- CY |
Flickering
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. -- Regards, Tom Ogilvy "cyrus" wrote in message ... 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("A2:D18").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, -- CY |
Flickering
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, -- CY "Tom Ogilvy" wrote: 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. -- Regards, Tom Ogilvy "cyrus" wrote in message ... 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("A2:D18").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, -- CY |
| All times are GMT +1. The time now is 05:08 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com