XL 2016 redimensionner un userform avec la souris

Fabien35200 · 27 Mai 2020

Bonjour à tous,

je cherche à pouvoir redimensionner un userform avec la souris comme toute fenetre sur windows.J ai testé ce code parmis bcp d autre mais aucun effet:

VB:

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        If X > Me.Width - 10 And Y > Me.Height - 10 Then
            Me.Width = X
            Me.Height = Y
        End If
    End If
End Sub

merci par avance pour votre aide.

Cordialement.

Fabien.

patricktoulon · 28 Mai 2020

re
ben voila

VB:

'*********************************************************************************
'                       Collection UserForm Patricktoulon                        *
'                USERFORM REDIMENTIONABLE AVEC LA SOURIS SANS API                *
'                                                                                *
'Auteur:patricktoulon sur Exceldownload                                          *
'version 2.0 sans controls label pilote                                          *
'date version :24/03/2020                                                        *
'l'userform est redimmentionnable par les 4 cotés et les 4 angles                *
'le mouse pointeur vous indique le sens et le type de...

GALOUGALOU · 28 Mai 2020

bonjour fabien35200 bonjour le forum
un lien avec une solution

Resize userform

Resize userform without APIs

www.andypope.info

cordialement
galougalou

Fabien35200 · 28 Mai 2020

Bonjour Galougalou,

merci pour ton retour,mais je souhaiterai que les éléments qui se situent dans l userform puisse s adapter à la nouvelle échelle du rétrécissement ou de l agrandissement.En effet ,lorsqu on modifie la taille de la fenêtre sur ton fichier ,les case peuvent être cacher par la suite.
Aurais tu une idée pour cela?
Merci par avance.

VIARD · 28 Mai 2020

Bonjour Galougalou, Fabien et à tous

Une autre solution sans API, de Maître TI.
Je l'adapte suivant mes besoins, très pratique quand on utilise une tablette.
voici le code:

Code:

Option Explicit

'Thierry'démo pour ajustement USF, January 2004

Const Largeur As Long = 367
Const Hauteur As Long = 400
Dim Coef As Long
Dim ActionSpin As String
Dim ActionList As String
---------------------------
Private Sub UserForm_initialize()
With Me.SpinButton1
.Value = 100
.Min = 50
.Max = 200
End With
Reglage
End Sub
----------------------
Private Sub SpinButton1_SpinUp()
ActionSpin = "Plus"
Reglage
End Sub
-------------------------------
Private Sub SpinButton1_SpinDown()
ActionSpin = "Moins"
Reglage
End Sub
--------------------------------
Private Sub Reglage()
With Me
Coef = .SpinButton1 - 100
.Height = ((Hauteur / 100) * Coef) + Hauteur
.Width = ((Largeur / 100) * Coef) + Largeur
.Zoom = .SpinButton1
End With
End Sub

A+ Jean-Paul

Fabien35200 · 28 Mai 2020

bonjour Jean Paul,merci pour ta contribution.Effectivement il fait le job ,mais l ideal serait d avoir ton code et celui de Galougalou en 1 pour n avoir que la souris dans l angle qui gère.

patricktoulon · 28 Mai 2020

bonjour
redimensionner l'userform avec la souris sans api Windows en voila une belle histoire
allez Kado (par les 4 angle et coté a l’intérieur )

VB:

'*********************************************************************************
'                       Collection UserForm Patricktoulon                        *
'                USERFORM REDIMENTIONABLE AVEC LA SOURIS SANS API                *
'                                                                                *
'Auteur:patricktoulon sur Exceldownload                                          *
'version 2.0 sans controls label pilote                                          *
'date version :24/03/2020                                                        *
'l'userform est redimmentionnable par les 4 cotés et les 4 angles                *
'le mouse pointeur vous indique le sens et le type de redimmentionnement         *
'une contante booleenne au depart pour decider si il est resizable ou pas        *
'*********************************************************************************
'Option Explicit
Const ZesiZable As Boolean = True    ' false si on ne veux pas qu'il soit redimentionable
Dim oldx#, oldy#
Private Sub UserForm_MouseDown(ByVal button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    oldx = X: oldy = Y
End Sub

Private Sub UserForm_MouseMove(ByVal button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If ZesiZable Then
        Dim mp As Variant, H$, Coté$
        If Y < 20 Then H = "H" Else H = "M"
        If Y > Me.InsideHeight - 20 Then H = "B"
        If X < 20 Then Coté = "G" Else Coté = "M"
        If X > Me.InsideWidth - 20 Then Coté = "D"
        mp = H & Coté
        mp = Switch(mp = "HG", 8, mp = "BD", 8, mp = "HD", 6, mp = "BG", 6, mp = "HM", 7, mp = "BM", 7, mp = "MM", 0, mp = "MG", 9, mp = "MD", 9)
        If Me.MousePointer <> mp Then Me.MousePointer = mp
        If button = 1 Then
            xx = X + 20
          Select Case H & Coté
            Case "MM": Me.Left = Me.Left + (X - oldx): Me.Top = Me.Top + (Y - oldy): Exit Sub
            Case "HG": Me.Width = Me.Width - X: Me.Left = Me.Left + X: Me.Height = Me.Height - Y: Me.Top = Me.Top + Y
            Case "HD": Me.Width = X: Me.Height = Me.Height - Y: Me.Top = Me.Top + (Y)
            Case "BG": Me.Width = Me.Width - X: Me.Left = Me.Left + X: Me.Height = Y + 20
            Case "BD": Me.Width = X: Me.Height = Y + 20
            Case "MG": Me.Width = Me.Width - X: Me.Left = Me.Left + X
            Case "MD": Me.Width = X
            Case "HM": Me.Height = Me.Height - Y: Me.Top = Me.Top + (Y)
            Case "BM": Me.Height = Y + 20
             End Select
        End If
    End If
End Sub

démonstration

et noyeux joel

Fabien35200 · 28 Mai 2020

salut Patrick
merci pour le Kado
Il ne m adapte pas le contenu en fonction de la fentre,donc je pense qu au final je garder le button spin de Jean Paul et ajouter ton code.
Merci beaucoup les gars.

patricktoulon · 28 Mai 2020

a ben le contenu il faut le zoomer au prorata de la modif userform bien sur
je répond simplement au titre explicite de la demande
si tu veux le resize des controls avec pas de soucis de je te le donne

Fabien35200 · 28 Mai 2020

ca serait avec plaisir avec le resize des controls merci par avance.

patricktoulon · 28 Mai 2020

re
ben voila

VB:

'*********************************************************************************
'                       Collection UserForm Patricktoulon                        *
'                USERFORM REDIMENTIONABLE AVEC LA SOURIS SANS API                *
'                                                                                *
'Auteur:patricktoulon sur Exceldownload                                          *
'version 2.0 sans controls label pilote                                          *
'date version :24/03/2020                                                        *
'l'userform est redimmentionnable par les 4 cotés et les 4 angles                *
'le mouse pointeur vous indique le sens et le type de redimmentionnement         *
'une contante booleenne au depart pour decider si il est resizable ou pas        *
'*********************************************************************************
'Option Explicit
Const ZesiZable As Boolean = True    ' false si on ne veux pas qu'il soit redimentionable
Dim oldx#, oldy#
Dim large As Long
Dim haut As Long

Private Sub UserForm_Activate()
With Me: large = .Width: haut = .Height: End With
For Each ctrl In Me.Controls
        With ctrl
            .Tag = .Left & ";" & .Top & ";" & .Width & ";" & .Height
            On Error Resume Next
            .Tag = .Tag & ";" & .Font.Size
            Err.Clear
        End With
    Next
End Sub

Private Sub UserForm_MouseDown(ByVal button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    oldx = X: oldy = Y
End Sub

Private Sub UserForm_MouseMove(ByVal button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If ZesiZable Then
        Dim mp As Variant, H$, Coté$
        If Y < 20 Then H = "H" Else H = "M"
        If Y > Me.InsideHeight - 20 Then H = "B"
        If X < 20 Then Coté = "G" Else Coté = "M"
        If X > Me.InsideWidth - 20 Then Coté = "D"
        mp = H & Coté
        mp = Switch(mp = "HG", 8, mp = "BD", 8, mp = "HD", 6, mp = "BG", 6, mp = "HM", 7, mp = "BM", 7, mp = "MM", 0, mp = "MG", 9, mp = "MD", 9)
        If Me.MousePointer <> mp Then Me.MousePointer = mp
        If button = 1 Then
            xx = X + 20
          Select Case H & Coté
            Case "MM": Me.Left = Me.Left + (X - oldx): Me.Top = Me.Top + (Y - oldy): Exit Sub
            Case "HG": Me.Width = Me.Width - X: Me.Left = Me.Left + X: Me.Height = Me.Height - Y: Me.Top = Me.Top + Y
            Case "HD": Me.Width = X: Me.Height = Me.Height - Y: Me.Top = Me.Top + (Y)
            Case "BG": Me.Width = Me.Width - X: Me.Left = Me.Left + X: Me.Height = Y + 20
            Case "BD": Me.Width = X: Me.Height = Y + 20
            Case "MG": Me.Width = Me.Width - X: Me.Left = Me.Left + X
            Case "MD": Me.Width = X
            Case "HM": Me.Height = Me.Height - Y: Me.Top = Me.Top + (Y)
            Case "BM": Me.Height = Y + 20
             End Select
        End If
    End If
End Sub

Private Sub UserForm_Resize()
   Dim coeff
   newlarge = Me.Width / large
    newhaut = Me.Height / haut
    For Each ctrl In Me.Controls
        With ctrl
            mem = Split(.Tag, ";")
            .Left = mem(0) * newlarge: .Width = mem(2) * newlarge
            .Top = mem(1) * newhaut: .Height = mem(3) * newhaut
            On Error Resume Next
            coeff = IIf(newlarge < newhaut, newlarge, newhaut)
            .Font.Size = mem(4) * coeff
            Err.Clear
        End With
    Next

End Sub

demonstration

voila ton userform en caoutchouc

VIARD · 28 Mai 2020

Bonjour Patrick, Fabien, Galougalou

@fabien, il faut que le (spinButton) soit placé en haut à gauche dans l'user.
@patrick, je n'ai pas essayé, les composants à l'intérieur suivent-ils le mouvement.

patricktoulon · 28 Mai 2020

maintenant je peut te simplifier le truc avec les api au black compatible 32/64 si tu veux

VIARD · 28 Mai 2020

Désolé Patrick je n'ai pas vu ta réponse.

patricktoulon · 28 Mai 2020

@VIARD BONJOUR
VOIR MA DEMO
ils suivent

Fabien35200 · 28 Mai 2020

Merci enormement pour le code
par contre ,je suis debutant, qu est qu un api?

XL 2016 redimensionner un userform avec la souris

Fabien35200

XLDnaute Nouveau

patricktoulon

GALOUGALOU

XLDnaute Accro

Resize userform

Pièces jointes

Fabien35200

XLDnaute Nouveau

VIARD

XLDnaute Impliqué

Fabien35200

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

Fabien35200

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

Fabien35200

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

VIARD

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

VIARD

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

Fabien35200

XLDnaute Nouveau

Discussions similaires