Stop picture flashing as resized.

AlexanderBB

Well-known Member
Joined
Jul 1, 2009
Messages
1,835
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I didn't write this and can't remember where it came from. Consists of a Form and a class module.
An image file is loaded via the Forms Picture property, and a "handle" on the Form lets you drag the picture
to any size. It's brilliant. Except as you drag the picture it flashes and looks awful (while it's moving).
I did have some instructions for fixing this but I have lost them. Can someone help out please?
Here's the code, I hope it's enough to demo the problem.


Code:
Option Explicit
Private m_clsResizer As CResizer


Private Sub UserForm_Initialize()
    Set m_clsResizer = New CResizer
    m_clsResizer.Add Me
    
    Me.StartUpPosition = 0
    Me.Top = Application.Top + 25
    Me.Left = Application.Left + 25    
End Sub

Private Sub UserForm_Terminate()
    Set m_clsResizer = Nothing   
End Sub

Option Explicit

Private Const MFrameResizer = "FrameResizeGrab"
Private Const MResizer = "ResizeGrab"
Private WithEvents m_objResizer As MSForms.Frame
Private m_sngLeftResizePos As Single
Private m_sngTopResizePos As Single
Private m_blnResizing As Single
Private WithEvents m_frmParent As MSForms.UserForm
Private m_objParent As Object

Private Sub Class_Terminate()

    m_objParent.Controls.Remove MResizer
    
End Sub


Private Sub m_frmParent_Layout()
    
    If Not m_blnResizing Then
        With m_objResizer
            .Top = m_objParent.InsideHeight - .Height
            .Left = m_objParent.InsideWidth - .Width
        End With
    End If

End Sub


Private Sub m_objResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

    If Button = 1 Then
        m_sngLeftResizePos = x
        m_sngTopResizePos = Y
        m_blnResizing = True
    End If
    
End Sub
Private Sub m_objResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

    If Button = 1 Then
        With m_objResizer
            .Move .Left + x - m_sngLeftResizePos, .Top + Y - m_sngTopResizePos
            m_objParent.Width = m_objParent.Width + x - m_sngLeftResizePos
            m_objParent.Height = m_objParent.Height + Y - m_sngTopResizePos
            .Left = m_objParent.InsideWidth - .Width
            .Top = m_objParent.InsideHeight - .Height
        End With
    End If
    
End Sub
Private Sub m_objResizer_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    If Button = 1 Then
        m_blnResizing = False
    End If
End Sub

Public Function Add(Parent As Object) As MSForms.Frame
'
' add resizing control to bottom righthand corner of userform
'
    Dim labTemp As MSForms.Label
    
    Set m_frmParent = Parent
    Set m_objParent = Parent
    
    Set m_objResizer = m_objParent.Controls.Add("Forms.Frame.1", MFrameResizer, True)
    Set labTemp = m_objResizer.Add("Forms.label.1", MResizer, True)
    With labTemp
        With .Font
            .Name = "Marlett"
            .Charset = 2
            .size = 14
            .Bold = True
        End With
        .BackStyle = fmBackStyleTransparent
        .AutoSize = True
        .BorderStyle = fmBorderStyleNone
        .Caption = "o"
        .MousePointer = fmMousePointerSizeNWSE
        .ForeColor = RGB(100, 100, 100)
        .ZOrder
        .Top = 1
        .Left = 1
        .Enabled = False
    End With
    
    With m_objResizer
        .MousePointer = fmMousePointerSizeNWSE
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
        .ZOrder
        .Caption = ""
        .Width = labTemp.Width + 1
        .Height = labTemp.Height + 1
        .Top = m_objParent.InsideHeight - .Height
        .Left = m_objParent.InsideWidth - .Width
    End With
End Function
 
Last edited:

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
maybe as simple as application.screenupdating = false

Though images will rely on what your graphics processor can deal with, and you on screen colours, if you use 64bit colour compared to 16bit colour you may not perceive a difference, but the amount of memory required for 64 is exponentially much bigger than 16
 
Upvote 0
I tried screen updating and also setting the Picture to Nothing while it was being moved. Neither were any good.
Not sure how to change to 64 bit color.
I can get it working spot on Access, not that it helps!
 
Upvote 0
MS Programs were all built by someone else originally, so their VB is different and whilst MS laid common controls on the face, they all react differently. Colour is part of the common display settings for the machine
 
Upvote 0

Forum statistics

Threads
1,214,599
Messages
6,120,453
Members
448,967
Latest member
grijken

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top