Autres abréger un code sans classe

patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour a tous
je suis entrain de me faire un cecoupeur d'image et j'ai créé un label redimensionnables avec des poignées
je voudrais raccourcir le code en globalisant certaines actions (peut etre ) (mais sans classe pour 4 poignées c'est pas intéressant)
ensuite j'aimerais rectifier la cohérence du bouton avec le mouse up du label(cadre rouge)
le bouton a la base affiche ou masque les poignées
le mouse up du cadre rouge les affiche aussi sauf que je voudrais que la condition du bouton soit respectée
VB: 
Option Explicit
Dim XX#, YY#
Dim yz#, xz#


Private Sub CommandButton1_Click()
    With CommandButton1
        'If .Caption = "resize" Then cropseur_MouseUp 1, 1, 1, 1: .Caption = "Noresize" Else .Caption = "resize": cropseur_MouseDown 1, 1, 1, 1
    End With
End Sub

'enclenche le movable de cropseur et cache les poignées de redimentionnement
Private Sub cropseur_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HG.Visible = False
    HD.Visible = False
    BG.Visible = False
    BD.Visible = False
    XX = X: YY = Y
End Sub
'deplace le cropseur
Private Sub cropseur_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        cropseur.Move cropseur.Left + (X - XX), cropseur.Top + (Y - YY)
    End If
End Sub
'arrete le movable du cropseur
Private Sub cropseur_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If CommandButton1.Caption <> "resize" Then
        HG.Visible = True
        HD.Visible = True
        BG.Visible = True
        BD.Visible = True
    End If
    HG.Move cropseur.Left - HG.Width, cropseur.Top - HG.Height
    HD.Move cropseur.Left + cropseur.Width, cropseur.Top - HG.Height
    BG.Move cropseur.Left - BG.Width, cropseur.Top + cropseur.Height
    BD.Move cropseur.Left + cropseur.Width, cropseur.Top + cropseur.Height
    XX = 0: YY = 0
End Sub

'vu la dimention des poigné de redimentionnement
'on en a pas vraiment besoin on peut partire de zero dans le move

'memo position curseur  poignée haute gauche
'Private Sub HG_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'XX = X: YY = Y
'End Sub

'memo position curseur  poignée haute droite
'Private Sub HD_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'XX = X: YY = Y
'End Sub

'memo position curseur  poignée basse gauche
'Private Sub BG_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'XX = X: YY = Y
'End Sub

'memo position curseur  poignée basse droite
'Private Sub BD_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'XX = X: YY = Y
'End Sub

Private Sub HG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        yz = YY + Y
        xz = XX + X
        HG.Move HG.Left + (X - XX), HG.Top + (Y - YY)
        BG.Left = HG.Left
        HD.Top = HG.Top
        rollcrops
    End If
End Sub
Private Sub HD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        yz = YY + Y
        xz = XX + X
        HD.Move HD.Left + (X - XX), HD.Top + (Y - YY)
        BD.Left = HD.Left
        HG.Top = HD.Top
        rollcrops
    End If
End Sub


Private Sub BG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        yz = YY + Y
        xz = XX + X
        BG.Move BG.Left + (X - XX), BG.Top + (Y - YY)
        HG.Left = BG.Left
        BD.Top = BG.Top
        rollcrops
    End If
End Sub
Private Sub BD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        yz = YY + Y
        xz = XX + X
        BD.Move BD.Left + (X - XX), BD.Top + (Y - YY)
        HD.Left = BD.Left
        BG.Top = BD.Top
        rollcrops
    End If
End Sub

Sub rollcrops()
    cropseur.Move HG.Left + HG.Width, HG.Top + HG.Height, (HD.Left - HG.Left) - HG.Width, (BG.Top - HG.Top) - HG.Height
End Sub

Private Sub UserForm_Activate()
    cropseur_MouseUp 0, 0, 0, 0
End Sub
merci messieux ;)
 

Pièces jointes

  • control poignée resize.xlsm
    20.9 KB · Affichages: 13
Solution
laurent950
Patrick regarde une idée,
j'ai mis dans un tableau variant les labels (Pour chaqu'une des combinaisons)
re je precise les tags respectifsde:
HG.tag=HD:BG
HD.tag=HG:BD
BG.tag=BD:HG
BD.tag=BG:HD
Dim Pos As Variant
'MsgBox Me.HG.Name
Pos = Array(Me.HG, Me.BG, Me.HD)
'MsgBox Pos(1).Name

Cela fonctionne le principe à l'air correcte !

VB: 
Option Explicit
Dim XX#, YY#
Dim yz#, xz#

Private Sub CommandButton1_Click()
    With CommandButton1
        'If .Caption = "resize" Then cropseur_MouseUp 1, 1, 1, 1: .Caption = "Noresize" Else .Caption = "resize": cropseur_MouseDown 1, 1, 1, 1
    End With
End Sub

'enclenche le movable de cropseur et cache les poignées de redimentionnement
Private Sub cropseur_MouseDown(ByVal Button As Integer...
Trier par date Trier par votes
laurent950

laurent950

XLDnaute Barbatruc
Bonjour Patrick,
J'ai aussi cherché mais sans aucune réponse à mes nombreuses intérogations, cela dit je suis tombé sur ce poste et je me pose cette question de savoir si cela est possible avec :
https://www.developpez.net/forums/d...os-vba-excel/nom-controle-declenche-userform/

je copie colle le poste : c'est pas de moi (ci-dessous)
Bourquoi ne fais-tu alors pas tout simplement une procédure commune (appelons-là laproc), ainsi :
Code :
Private sub laproc(ctrl as control)
' et tu fais sur ctrrl ce que tu veux (instructions)
ctrl.SpecialEffect = fmSpecialEffectSunken
'etc.....
End sub
Il te suffira alors d'ajouter une ligne à chaque évènement click (pas cher)
Exemple :
Code :
Private Sub IMG_VuePrecedente_Click()
laproc IMG_VuePrecedente
' et ce que tu veuix faire d'autre, le cas échéant...
End Sub
Celà ne coûte pas cher et t'évite de faire une classe pour "simuler" un groupe de contrôles indexés...

Enfin je sais pas si cela est une piste, en tous cas je n'est pas su le faire fonctionner, mais je suis aussi très interressé par ce sujet que tu as évoqué

Laurent
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
Bonjour patrick,
Justement comment récuperer un contrôle dans un userforme directement c'est à dire :
- Entre le moment ou l'on click (dans le contrôle de l'userforme et / (Ce que l'ont arrive pas à récuperer avant d'arrivé directement (l'interception) à / Private Sub HD_MouseMove
- Comment Intercepter pour éviter d'écrire 4 fois cela :
HG_MouseMove
HD_MouseMove
BG_MouseMove
BD_MouseMove
- L'interception remplacera les 4 pour une seul écriture, J'ai pas trouver sans module de classe !

Il doit bien exister quelquechose car lorsque l'on click dans l'userforme cela renvois bien vers un evenement (alors comment le recuperer jsute avant cette redirection vers l'un d'eux ?
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour Laurent
je pensais a un truc comme ça
mais ca ne fonctionne pas va savoir pourquoi
en fait je globalise le move des 4
et plus particulièrement c'est les droites qui ne fonctionnent pas
VB: 
Option Explicit
Dim XX#, YY#
Dim yz#, xz#


Private Sub CommandButton1_Click()
    With CommandButton1
        'If .Caption = "resize" Then cropseur_MouseUp 1, 1, 1, 1: .Caption = "Noresize" Else .Caption = "resize": cropseur_MouseDown 1, 1, 1, 1
    End With
End Sub

'enclenche le movable de cropseur et cache les poignées de redimentionnement
Private Sub cropseur_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HG.Visible = False
    HD.Visible = False
    BG.Visible = False
    BD.Visible = False
    XX = X: YY = Y
End Sub
'deplace le cropseur
Private Sub cropseur_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        cropseur.Move cropseur.Left + (X - XX), cropseur.Top + (Y - YY)
    End If
End Sub
'arrete le movable du cropseur
Private Sub cropseur_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        HG.Visible = True
        HD.Visible = True
        BG.Visible = True
        BD.Visible = True
     HG.Move cropseur.Left - HG.Width, cropseur.Top - HG.Height
    HD.Move cropseur.Left + cropseur.Width, cropseur.Top - HG.Height
    BG.Move cropseur.Left - BG.Width, cropseur.Top + cropseur.Height
    BD.Move cropseur.Left + cropseur.Width, cropseur.Top + cropseur.Height
    XX = 0: YY = 0
End Sub



Private Sub HG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    rollcrops HG, Button, X, Y
End Sub

Private Sub HD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   rollcrops HD, Button, X, Y
End Sub


Private Sub BG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
           rollcrops BG, Button, X, Y
  End Sub

Private Sub BD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     rollcrops BD, Button, X, Y
End Sub

Sub rollcrops(ctrl, B, X, Y)
    Debug.Print ctrl.Left & "---" & X & "---" & Y
    Dim noms
    noms = Split(ctrl.Tag, ":")
    If B = 1 Then
         ctrl.Move BG.Left + X, ctrl.Top + Y
        Me.Controls(noms(1)).Left = ctrl.Left
        Me.Controls(noms(0)).Top = ctrl.Top
     End If
    On Error Resume Next
    
    cropseur.Top = HG.Top
    cropseur.Left = HG.Left
    cropseur.Height = HG.Top + HG.Height - BG.Top
    cropseur.Width = HD.Left - (HG.Left - HG.Width)
    'cropseur.Move HG.Left + HG.Width, HG.Top + HG.Height, (HD.Left - HG.Left) - HG.Width, (BG.Top - HG.Top) - HG.Height
End Sub

Private Sub UserForm_Activate()
    cropseur_MouseUp 0, 0, 0, 0
End Sub
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil

[OK je sors ;)]
A la lecture du titre, je croyais qu'il s'agissait d'abréger la souffrance d'un code (et ce, avec ou sans un enterrement de 1ère classe)
Mais je vois, que la victime bouge encore et comme disait David ;)
"Maintenant, Excel sait que les KodWTF sont là, qu'ils ont pris forme de macros VBA et qu'il lui faut convaincre un monde incrédule que le cauchemar a déjà commencé… »
[/OK je sors ;)]

PS: message du dimanche matin avec de l'ironie camaradesque, des miettes de pain noir, et une odeur de café chaud ;)
Souriez, c'est bientôt lundi ;)
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
bonjour Staple1600
:p :cool:
A la lecture du titre, je croyais qu'il s'agissait d'abréger la souffrance d'un code
Cliquez pour agrandir...
mon code ne souffrait pas ,il fonctionne parfaitement je voulais le réduire c'est tout
KodWTF :call off duty c'est pas mon monde ;)

et au regard de ce qui ce passe avec une sub globale une classe aurait le même effet
il y a un truc qui m’échappe avec le x et y dans cette version
re je precise les tags respectifsde:
HG.tag=HD:BG
HD.tag=HG:BD
BG.tag=BD:HG
BD.tag=BG:HD
 
Dernière édition:
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
Bonjour Patrick,
Je suis entrain de regarder le code de ton poste #7
ici tu fais un découpage : noms = Split(ctrl.Tag, ":")
tu as écrit quoi dans le ctrl.Tag ' Tag c'est pour marquer donc faire quelques choses d'optionel et je sais pas se que tu as consigné dans cette espace réservé optionel ?
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
Patrick regarde une idée,
j'ai mis dans un tableau variant les labels (Pour chaqu'une des combinaisons)
re je precise les tags respectifsde:
HG.tag=HD:BG
HD.tag=HG:BD
BG.tag=BD:HG
BD.tag=BG:HD
Dim Pos As Variant
'MsgBox Me.HG.Name
Pos = Array(Me.HG, Me.BG, Me.HD)
'MsgBox Pos(1).Name

Cela fonctionne le principe à l'air correcte !

VB: 
Option Explicit
Dim XX#, YY#
Dim yz#, xz#

Private Sub CommandButton1_Click()
    With CommandButton1
        'If .Caption = "resize" Then cropseur_MouseUp 1, 1, 1, 1: .Caption = "Noresize" Else .Caption = "resize": cropseur_MouseDown 1, 1, 1, 1
    End With
End Sub

'enclenche le movable de cropseur et cache les poignées de redimentionnement
Private Sub cropseur_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HG.Visible = False
    HD.Visible = False
    BG.Visible = False
    BD.Visible = False
    XX = X: YY = Y
End Sub
'deplace le cropseur
Private Sub cropseur_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        cropseur.Move cropseur.Left + (X - XX), cropseur.Top + (Y - YY)
    End If
End Sub
'arrete le movable du cropseur
Private Sub cropseur_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If CommandButton1.Caption <> "resize" Then
        HG.Visible = True
        HD.Visible = True
        BG.Visible = True
        BD.Visible = True
    End If
    HG.Move cropseur.Left - HG.Width, cropseur.Top - HG.Height
    HD.Move cropseur.Left + cropseur.Width, cropseur.Top - HG.Height
    BG.Move cropseur.Left - BG.Width, cropseur.Top + cropseur.Height
    BD.Move cropseur.Left + cropseur.Width, cropseur.Top + cropseur.Height
    XX = 0: YY = 0
End Sub
Private Sub HG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Pos As Variant
Pos = Array(Me.HG, Me.BG, Me.HD)
    rollcrops Button, Shift, X, Y, Pos
End Sub
Private Sub HD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Pos As Variant
Pos = Array(Me.HD, Me.BD, Me.HG)
   rollcrops Button, Shift, X, Y, Pos
End Sub
Private Sub BG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Pos As Variant
Pos = Array(Me.BG, Me.HG, Me.BD)
    rollcrops Button, Shift, X, Y, Pos
  End Sub
Private Sub BD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Pos As Variant
Pos = Array(Me.BD, Me.HD, Me.BG)
     rollcrops Button, Shift, X, Y, Pos
End Sub
Sub rollcrops(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single, ByVal Pos As Variant)
    If Button = 1 Then
        yz = YY + Y
        xz = XX + X
        Pos(0).Move Pos(0).Left + (X - XX), Pos(0).Top + (Y - YY)
        Pos(1).Left = Pos(0).Left
        Pos(2).Top = Pos(0).Top
    End If
cropseur.Move HG.Left + HG.Width, HG.Top + HG.Height, (HD.Left - HG.Left) - HG.Width, (BG.Top - HG.Top) - HG.Height
End Sub

Private Sub UserForm_Activate()
    cropseur_MouseUp 0, 0, 0, 0
End Sub
 

Pièces jointes

  • control poignée resize (3).xlsm
    31.4 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif
Solution
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
bon finalement c'est pas si mal Laurent
j'ai dé variabiliser les array corriger button et ajouter le resize de cropseur
enlever l'argument ctrl qui ne servait plus a rien puisque c'est pos(0) le control commandeur
VB: 
Option Explicit
Dim XX#, YY#
Dim yz#, xz#

Private Sub CommandButton1_Click()
    With CommandButton1
        'If .Caption = "resize" Then cropseur_MouseUp 1, 1, 1, 1: .Caption = "Noresize" Else .Caption = "resize": cropseur_MouseDown 1, 1, 1, 1
    End With
End Sub

'enclenche le movable de cropseur et cache les poignées de redimentionnement
Private Sub cropseur_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HG.Visible = False
    HD.Visible = False
    BG.Visible = False
    BD.Visible = False
    XX = X: YY = Y
End Sub
'deplace le cropseur
Private Sub cropseur_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        cropseur.Move cropseur.Left + (X - XX), cropseur.Top + (Y - YY)
    End If
End Sub
'arrete le movable du cropseur
Private Sub cropseur_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        HG.Visible = True
        HD.Visible = True
        BG.Visible = True
        BD.Visible = True
     HG.Move cropseur.Left - HG.Width, cropseur.Top - HG.Height
    HD.Move cropseur.Left + cropseur.Width, cropseur.Top - HG.Height
    BG.Move cropseur.Left - BG.Width, cropseur.Top + cropseur.Height
    BD.Move cropseur.Left + cropseur.Width, cropseur.Top + cropseur.Height
    XX = 0: YY = 0
End Sub



Private Sub HG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(HG, BG, HD)
End Sub

Private Sub HD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Pos, Array(HD, BD, HG)
End Sub

Private Sub BG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(BG, HG, BD)
End Sub

Private Sub BD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(BD, HD, BG)
End Sub

Sub rollcrops(B, X, Y, Pos)
If B = 1 Then
Pos(0).Move Pos(0).Left + (X - 2), Pos(0).Top + (Y - 2)
Pos(1).Left = Pos(0).Left
Pos(2).Top = Pos(0).Top
cropseur.Move HG.Left + HG.Width, HG.Top + HG.Height, HD.Left - (HG.Left + HG.Width), BG.Top - (HG.Top + HG.Height)
End If
End Sub
Private Sub UserForm_Activate()
    cropseur_MouseUp 0, 0, 0, 0
End Sub

mon mis a part le fait que les 3 controls sont injecté c'est pas très différent de la version 2 sauf que je l’obtiens par le split du tag
ca n'explique donc pas le soucis pour les droites que j'ai avec la version 2
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
C'est vrais que c'est pas si mal patrick.
La version 2 c'est le poste #7 ?
C'est pas cette erreur ?
1581852874380.png

rollcrops Button, Shift, X, Y
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

cp4
  • Résolu(e)
XL 2010 [RESOLU]Adapter Module de Classe
2
Réponses
29
Affichages
2 K
cp4
cp4
patricktoulon
  • Question
Autres Petite mise a jour (exceptionnellement pour cp4) du calendar V4.1(OLDVERSION)
2
Réponses
21
Affichages
1 K
patricktoulon
patricktoulon
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
599
dadu35
D
N
  • Résolu(e)
Microsoft 365 Code fonction pour création code aléatoire
2 3
Réponses
32
Affichages
604
NONO14
N
H
  • Question
XL 2013 Evènement "MouseMove" dans une module de classe pour plusieurs userform
Réponses
6
Affichages
810
patricktoulon
patricktoulon
D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
463
fanch55
fanch55
patricktoulon
  • Résolu(e)
Autres que penses vous de ce mini test benchmark(timer plus precis)
Réponses
6
Affichages
603
patricktoulon
patricktoulon
Y
  • Résolu(e)
XL 2019 Besoin d'aide "Erreur d'execution '424' : Objects requis"
Réponses
2
Affichages
460
YAP32
Y
N
  • Résolu(e)
Microsoft 365 Aide pour un code Vba
2 3
Réponses
32
Affichages
966
Nicolas JACQUIN
Nicolas JACQUIN
cathodique
  • Résolu(e)
XL 2010 Masque de saisie textbox Téléphone Public
Réponses
8
Affichages
686
cathodique
cathodique

Membres actuellement en ligne

11 membres et 78 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 109
Messages
2 116 322
Membres
112 717
dernier inscrit
doguet