Stop picture flashing as resized.

AlexanderBB

Well-known Member
Joined
Jul 1, 2009
Messages
1,633
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:

Some videos you may like

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,099
Office Version
2019, 2016, 2013
Platform
Windows
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
 

AlexanderBB

Well-known Member
Joined
Jul 1, 2009
Messages
1,633
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!
 

mole999

Moderator
Joined
Oct 23, 2004
Messages
10,099
Office Version
2019, 2016, 2013
Platform
Windows
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
 

Forum statistics

Threads
1,089,270
Messages
5,407,304
Members
403,132
Latest member
Black_Mamba_1666

This Week's Hot Topics

Top