Userform movable and resizable

J

Jaye7

Well-known Member
Joined
Jul 7, 2010
Messages
1,066
I have the following script which makes it so that you can resize a userform by dragging the bottom right corner.

Can anyone please provide a script so that I can resize it from
1 - The top right corner
2 - The bottom left corner
3 - The top left corner.

Sometimes I have textboxes in certain positions and want to resize to fit a specific textbox which this does not allow and will include every textbox above the textbox that I want.



Code: 
Dim myClipbd As New DataObject
Private m_sngX As Single
Private m_sngY As Single
Option Explicit

Private Const MResizer = "ResizeGrab"
Private WithEvents m_objResizer As MSForms.Label
Private m_sngLeftResizePos As Single
Private m_sngTopResizePos As Single
Private m_blnResizing As Single



Private Sub UserForm_Activate()


'RemoveCaption GetForegroundWindow

'Call formheight




Set m_objResizer = Me.Controls.Add("Forms.label.1", MResizer, True)
    With m_objResizer
        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 = Me.InsideHeight - .Height
        .Left = Me.InsideWidth - .Width
    End With
End Sub



Private Sub m_AddResizer()
'
' add resizing control to bottom righthand corner of userform
'
    
    
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
    

'If Button = 1 Then

'End If

'If Button And 1 Then

'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
            Me.Width = Me.Width + X - m_sngLeftResizePos
            Me.Height = Me.Height + Y - m_sngTopResizePos
            .Left = Me.InsideWidth - .Width
            .Top = Me.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



Private Sub UserForm_Initialize()

   ' m_AddResizer
    
End Sub
Private Sub UserForm_Terminate()

    Me.Controls.Remove MResizer
    
End Sub


Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

If Button = 1 Then
m_sngX = X
m_sngY = Y
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

If Button = 1 Then
Me.Left = X + Me.Left - m_sngX
Me.Top = Y + Me.Top - m_sngY

End If
End Sub
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
Hello Jaye7,

Copy this code to a separate VBA module. Add a call to the macro MakeFormResizable in the UserForm's UserForm_Activate() event. You cna then resize it like a regular window.
Code: 
'Written: February 14, 2011
'Author:  Leith Ross
'
'NOTE:  This code should be executed within the UserForm_Activate() event.

Private Declare Function GetForegroundWindow Lib "User32.dll" () As Long

Private Declare Function GetWindowLong _
  Lib "User32.dll" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, _
     ByVal nIndex As Long) _
  As Long
               
Private Declare Function SetWindowLong _
  Lib "User32.dll" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, _
     ByVal nIndex As Long, _
     ByVal dwNewLong As Long) _
  As Long

Private Const WS_THICKFRAME As Long = &H40000
Private Const GWL_STYLE As Long = -16

Public Sub MakeFormResizable()

  Dim lStyle As Long
  Dim hWnd As Long
  Dim RetVal
  
    hWnd = GetForegroundWindow
  
    'Get the basic window style
     lStyle = GetWindowLong(hWnd, GWL_STYLE) Or WS_THICKFRAME

    'Set the basic window styles
     RetVal = SetWindowLong(hWnd, GWL_STYLE, lStyle)

End Sub
Sincerely,
Leith ROss
 
Upvote 0
Hi Leith,

Thanks for the script.

The only thing is that when it resizes ie. you drag the left side towards the right side I wanted it so that only the right side data is showing not the left side and also if you drag it from the top I wanted it to be able to cover the top textboxes leaving only the ones that I want visible.

May be this is not possible.

I wanted it so that no matter what textbox I wanted to resize the form around I could do it.
 
Upvote 0
Hello Jaye7,

It is probably possible to do. The amount of additional API code and work needed to make it happen is likely to outweigh the benefits.

Sincerely,
Leith Ross
 
Upvote 0
I tried this nifty code (I happen to be using Word....). I do see a user window with a thick frame, but I can't grab anything on the frame and resize. I looked up GetWindowLong and the MS info says to use GetWindowLongPtr for compatibility with 64 bit systems. I'm using win 7, 64-bit. Is this the cause of my problem? If so, can you tell me how to convert to GetWindowLongPtr?

Thanks
Al Huneke
 
Upvote 0
Hello Al,

You only need to use LongPtr if your Windows system is 64 bit and your version of Office is also 64 bit. If you are running 32 bit Office on 64 bit Windows , like a typical Windows 7 installation, then it is taken care of automatically.
 
Upvote 0
I am using 32-bit Office on 64-bit Windows 7. My real question still is why do I get the thick frame, but I can't grab it? I assume resizing the window would involve grabbing the right border (for instance) and dragging but this has no effect. Any suggestions?

Thanks
Al
 
Upvote 0
Mac Labels don't work well with the MouseMove event, so this uses four TextBoxes.

There needs to be checking added for exceeding the original size.

Code: 
Public WithEvents LLResizer As MSForms.TextBox
Public WithEvents TLResizer As MSForms.TextBox
Public WithEvents TRResizer As MSForms.TextBox
Public WithEvents LRResizer As MSForms.TextBox

Dim X0 As Single, Y0 As Single

Dim Width0 As Single, Height0 As Single
Dim VInterval As Single

Private Sub LLResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If Button = 1 Then
        If X0 <> 0 Then
            LLResizer.Left = Application.Max(0, LLResizer.Left + (x - X0))
            Me.Width = Width0 - LLResizer.Left
            Me.ScrollLeft = LLResizer.Left
            Me.Left = Me.Left + (x - X0)
            
            LLResizer.Top = LLResizer.Top + (y - Y0)
            Me.Height = LLResizer.Top + LLResizer.Height + VInterval
            
            TLResizer.Left = LLResizer.Left
            LRResizer.Top = LLResizer.Top
        End If
    End If
End Sub

Private Sub LRResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If Button = 1 Then
        If X0 <> 0 Then
            LRResizer.Left = LRResizer.Left + (x - X0)
            Me.Width = Me.Width + (x - X0)
            
            LRResizer.Top = LRResizer.Top + (y - Y0)
            Me.Height = Me.Height + (y - Y0)
            
            TRResizer.Left = LRResizer.Left
            LLResizer.Top = LRResizer.Top
        End If
    End If
End Sub

Private Sub TLResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If Button = 1 Then
        If X0 <> 0 Then
            TLResizer.Left = Application.Max(0, TLResizer.Left + (x - X0))
            Me.Width = Width0 - TLResizer.Left
            Me.ScrollLeft = TLResizer.Left
            Me.Left = Me.Left + (x - X0)
            
            TLResizer.Top = TLResizer.Top + (y - Y0)
            Me.Height = Me.Height - (y - Y0)
            Me.ScrollTop = TLResizer.Top
            Me.Top = Me.Top + (y - Y0)
            
            LLResizer.Left = Me.ScrollLeft
            TRResizer.Top = TLResizer.Top
        End If
    End If
End Sub

Private Sub TRResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
     If Button = 1 Then
        If X0 <> 0 Then
            TRResizer.Left = TRResizer.Left + (x - X0)
            Me.Width = Me.Width + (x - X0)
            
            TRResizer.Top = TRResizer.Top + (y - Y0)
            Me.Height = Me.Height - (y - Y0)
            Me.ScrollTop = TRResizer.Top
            Me.Top = Me.Top + (y - Y0)
            
            TLResizer.Top = TRResizer.Top
            LRResizer.Left = TRResizer.Left
        End If
    End If
End Sub

Private Sub LLResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If x > 0 And y > 0 Then
        X0 = x
        Y0 = y
    Else
        X0 = 0
        Y0 = 0
    End If
End Sub
Private Sub LRResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If x > 0 And y > 0 Then
        X0 = x
        Y0 = y
    Else
        X0 = 0
        Y0 = 0
    End If
End Sub
Private Sub TLResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If x > 0 And y > 0 Then
        X0 = x
        Y0 = y
    Else
        X0 = 0
        Y0 = 0
    End If
End Sub
Private Sub TRResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If x > 0 And y > 0 Then
        X0 = x
        Y0 = y
    Else
        X0 = 0
        Y0 = 0
    End If
End Sub

Private Sub UserForm_Activate()
    With LLResizer
        .Height = 30
        .Width = 30
        .BorderStyle = fmBorderStyleSingle
        .Top = Me.InsideHeight - .Height
        .Left = 0
        .TabStop = False
        .Locked = False
        .MousePointer = fmMousePointerSizeNESW
    End With
    With TLResizer
        .Height = 30
        .Width = 30
        .BorderStyle = fmBorderStyleSingle
        .Top = 0
        .Left = 0
        .TabStop = False
        .Locked = False
        .MousePointer = fmMousePointerSizeNWSE
    End With
    With TRResizer
        .Height = 30
        .Width = 30
        .BorderStyle = fmBorderStyleSingle
        .Top = 0
        .Left = Me.InsideWidth - .Width
        .TabStop = False
        .Locked = False
        .MousePointer = fmMousePointerSizeNESW
    End With
    With LRResizer
        .Height = 30
        .Width = 30
        .BorderStyle = fmBorderStyleSingle
        .Top = Me.InsideHeight - .Height
        .Left = Me.InsideWidth - .Width
        .TabStop = False
        .Locked = False
        .MousePointer = fmMousePointerSizeNWSE
    End With
    With Me
        .ScrollHeight = .InsideHeight
        .ScrollWidth = .InsideWidth
        Width0 = .Width
        Height0 = .Height
        VInterval = .Height - .InsideHeight
    End With
End Sub

Private Sub UserForm_Initialize()
    Set LLResizer = TextBox1
    Set TLResizer = TextBox3
    Set TRResizer = TextBox4
    Set LRResizer = TextBox5
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Userform button click
Replies
1
Views
243
SQUIDD
S
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
309
Minh Tuan VN
M
P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
47
6StringJazzer
6StringJazzer
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
165
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

Share this page

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