Autres abréger un code sans classe

patricktoulon · 15 Février 2020

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

laurent950 · 16 Février 2020

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...

Staple1600 · 15 Février 2020

Bonjour le fil

patricktoulon
Je ne sais pas ce qu'est un cecoupeur

(mon dico non plus , et Excel encore moins )

patricktoulon · 15 Février 2020

re
hahaha 'coupeur" j'ai eu une crise du syndrome de la tourette

laurent950 · 15 Février 2020

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

patricktoulon · 15 Février 2020

re
bonsoir Laurent ,je pige pas le rapport en fait a ma demande
une prc globale oui mais certaine choses doivent etre fait dans leur événement ce qui rend la proc globale difficile

laurent950 · 15 Février 2020

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 ?

patricktoulon · 16 Février 2020

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

Staple1600 · 16 Février 2020

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

patricktoulon · 16 Février 2020

re
bonjour Staple1600

A la lecture du titre, je croyais qu'il s'agissait d'abréger la souffrance d'un code

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

laurent950 · 16 Février 2020

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 ?

patricktoulon · 16 Février 2020

RE
bonjour Laurent j'ai édité mon post précèdent

laurent950 · 16 Février 2020

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

patricktoulon · 16 Février 2020

je ne doute pas que cela fonctionne meme sans tester mais on reviens un peu a l'initial
je vais tester quand meme

re testé
bon le if button dans rollcrops c'est if b
b etant l'argument button

patricktoulon · 16 Février 2020

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

laurent950 · 16 Février 2020

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

rollcrops Button, Shift, X, Y

Autres abréger un code sans classe

patricktoulon

XLDnaute Barbatruc

Pièces jointes

laurent950

Staple1600

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

Discussions similaires