AlexanderBB
Well-known Member
- Joined
- Jul 1, 2009
- Messages
- 2,072
- Office Version
- 2019
- 2010
- Platform
- 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.
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: