IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Vos contributions VB6 Discussion :

Ajout d'événements Mouse à des composant ne les ayant pas ou pas tous, plus prise en compte de la roulette


Sujet :

Vos contributions VB6

  1. #1
    Modérateur
    Avatar de ProgElecT
    Homme Profil pro
    Retraité
    Inscrit en
    Décembre 2004
    Messages
    6 067
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 67
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Communication - Médias

    Informations forums :
    Inscription : Décembre 2004
    Messages : 6 067
    Points : 17 152
    Points
    17 152
    Par défaut Ajout d'événements Mouse à des composant ne les ayant pas ou pas tous, plus prise en compte de la roulette
    Salut

    Aurai-je réinventé la roue .
    Je vous propose l’ajout d’événements souris pour des composants qui ne les ont pas ou bien qui ne les ont pas tous, par contre le composant doit avoir impérativement la propriété Hwnd.
    MouseEntrer, MouseDown, MouseMove, MouseUp et MouseSortie.
    MouseEntrer : équivalent OnMouseOver en HTML, cet événement survient une seule fois lorsque le curseur atteint la surface du composant.
    MouseSortie : équivalent OnMouseOut en HTML, cet événement survient une seule fois lorsque le curseur quitte la surface du composant.
    Pour les autres, même fonction que l’événement de base.

    Dans le projet d’utilisation fournit, c’est le VScroll1 qui a été ce pourquoi j’ai recherché à pouvoir avoir les événements MouseEntrer, pour afficher le label valeur, et MouseSortie, le fait de détecter la sortie du curseur de la surface du composant obligeant d’utiliser tous les MouseMove des surfaces autour du VScroll1.
    Pour le projet d’utilisation, un module.bas avec ce
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    Option Explicit
    '*********************** Module permetant de créer des événements suivant la position du curseur de la souris **************
    '--- prés requis ----------------------------------------------------------------------------------------
    '--- le composant pour lequel on veux créer l'événement doit imperativement avoir la propriété Hwnd -----
    '--------------------------------------------------------------------------------------------------------
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    'Récupère la position du curseur, en coordonnées d'écran.
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    'Récupère le handle de la fenêtre qui contient le point spécifié.
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    'Récupère le handle de la fenêtre parent de la fenêtre enfant spécifié.
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Dim Pxy As POINTAPI, HwndLut As Long
     
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    'Récupère les dimensions du rectangle de la fenêtre spécifiée.
    'Les dimensions sont indiquées en coordonnées d'écran qui sont relatives au coin supérieur gauche de l'écran.
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
     
    'Pour lire les touches du clavier
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
     
    'Pour surveiller le curseur de la souris
    'Crée une minuterie avec la valeur de délai d'attente spécifié.
    Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _
                                                   ByVal nIDEvent As Long, ByVal uElapse As Long, _
                                                   ByVal lpTimerFunc As Long) As Long
    'Détruit la minuterie spécifiée.
    Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
     
    Dim OldCtrlActiver As String, CtrlActiver As String, CtrlAsurveiller As Boolean
    Dim MemoBtPresser As Integer, MemoShift As Integer
     
    Public Sub SurveillanceMouse()
    'surveillance du deplacement du curseur de la souris
    GetCursorPos Pxy 'Obtention de la position actuelle de la souris
    HwndLut = WindowFromPoint(Pxy.X, Pxy.Y) 'Obtention de la fenêtre sous la souris
    If Identification(HwndLut) = False Then
        'recherche du Hwnd parent par apport au Hwnd sous le curseur de la souris (cas du ComboBox)
        If GetParent(HwndLut) <> 0 Then Identification GetParent(HwndLut) 'forcement un ComboBox
    End If
    If CtrlAsurveiller = True Then
        If CtrlActiver <> OldCtrlActiver Then
            'la souris vient de quitté un contrôle qui était surveillé
            LancerEventCtrl OldCtrlActiver, "Quitte"
            'la souris commence a passer au dessus du nouveau contrôle devant être surveillé
            LancerEventCtrl CtrlActiver, "Entre"
            OldCtrlActiver = CtrlActiver
        End If
    End If
    If CtrlAsurveiller = False Then
        If CtrlActiver <> "" Then 'la souris quitte le contrôle qui était surveillé
            LancerEventCtrl CtrlActiver, "Quitte"
            CtrlActiver = "": OldCtrlActiver = ""
            MemoBtPresser = 0: MemoShift = 0
        End If
    End If
    DoEvents
    End Sub
    Private Sub LancerEventCtrl(NomDuCtrl As String, procédureAlancer As String)
    Dim Lobjet As Control
    For Each Lobjet In Screen.ActiveForm.Controls
        If Lobjet.Name = NomDuCtrl Then
            If procédureAlancer = "Entre" Then Ctrl_MouseEntrer Lobjet Else Ctrl_MouseSortie Lobjet
            Exit For
        End If
    Next
    End Sub
    Private Function Identification(HwndSoumis As Long) As Boolean
    Dim Lobjet As Control
    For Each Lobjet In Screen.ActiveForm.Controls
        Select Case TypeName(Lobjet)
            'les composants qui n'ont pas les évènements souris et/ou
            'un composant qui n'a pas l'évènement entrée/sortie sur la surface du contrôle, ici pour demo un PictureBox
            Case "ComboBox", "DriveListBox", "HScrollBar", "VScrollBar", "PictureBox"
                 If Lobjet.hwnd = HwndSoumis Then
                    Identification = True
                    CtrlActiver = Lobjet.Name
                    RecupeParametres Lobjet
                    Exit For
                 End If
        End Select
    Next
    CtrlAsurveiller = Identification
    End Function
     
    Private Sub RecupeParametres(Lecontrôle As Control)
    '--- Lecture des états et positionnement du curseur souris ---
    'Button As Integer, Shift As Integer, X As Single, Y As Single
     
    'Button = 1 vbLeftButton, 2 vbRightButton et 4 vbMiddleButton
    Dim XButton As Integer
    'détection d'un ou plusieurs boutons en appuis
    If GetAsyncKeyState(vbLeftButton) <> 0 Then XButton = vbLeftButton
    If GetAsyncKeyState(vbRightButton) <> 0 Then XButton = XButton + vbRightButton
    If GetAsyncKeyState(vbMiddleButton) <> 0 Then XButton = XButton + vbMiddleButton
     
    'Shift = MAJ, CTRL et ALT
    Dim XShift As Integer
    'détection d'une ou plusieurs touches du clavier en appuis
    If GetAsyncKeyState(vbKeyShift) <> 0 Then XShift = vbShiftMask
    If GetAsyncKeyState(vbKeyControl) <> 0 Then XShift = XShift + vbCtrlMask
    If GetAsyncKeyState(vbKeyMenu) <> 0 Then XShift = XShift + vbAltMask
     
    Dim Rectangle As RECT, PosX As Long, PosY As Long
    'récupération des cordonnées du curseur souris en référence du coin haut à gauche du contrôle
    GetWindowRect Lecontrôle.hwnd, Rectangle
    PosX = Pxy.X - Rectangle.Left: PosY = Pxy.Y - Rectangle.Top
     
    '--- Enclanchement de la procédure évènement appropriée ---
    If CtrlActiver = OldCtrlActiver Then
        If XButton > MemoBtPresser And XButton <> 0 Then
            Ctrl_MouseDown Lecontrôle, XButton, XShift, PosX, PosY
        End If
        If XButton = MemoBtPresser Then
            Ctrl_MouseMove Lecontrôle, XButton, XShift, PosX, PosY
        End If
        If XButton < MemoBtPresser Then
            Ctrl_MouseUp Lecontrôle, XButton, XShift, PosX, PosY
        End If
    End If
     
    MemoBtPresser = XButton: MemoShift = XShift
     
    End Sub
     
     
    '---------------------------- procédures d'évènements pour les contrôles n'en ayant pas ---------------------------
    Private Sub Ctrl_MouseEntrer(QuelCtrl As Control)
    'le curseur de la souris entre sur la surface du contrôle
    With Screen.ActiveForm
        Select Case QuelCtrl.Name
            Case "HScroll1": .Label1.Visible = True
            Case "VScroll1": .Label2.Visible = True
            Case "Picture1"
                'Gestion d'un même type de contrôle ayant le même nom mais sur 2 formulaires différents
                If .Name = "FormDemo" Then
                    .Picture1.Picture = LoadPicture(App.Path & "\Image2.jpg")
                    .Label3.Visible = True
                    .Label4.Visible = True
                    Else
                    'FormDemo2
                    .Picture1.Cls
                    .Picture1.Print "la souris vient d'entrée"
                End If
        End Select
    End With
    End Sub
    Private Sub Ctrl_MouseDown(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
    Select Case QuelCtrl.Name
        Case "HScroll1"
           If Shift = 4 Then Screen.ActiveForm.HScroll1.LargeChange = 10
        'Case "autre composant"
        'Case "autre ....."
    End Select
    End Sub
    Private Sub Ctrl_MouseMove(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
    'X et Y sont dans l'unité Pixels, c'est voulu pour être utilisé par les APIs
    Select Case QuelCtrl.Name
        Case "Picture1"
            'Gestion d'un même type de contrôle ayant le même nom mais sur 2 formulaires différents
            If Screen.ActiveForm.Name = "FormDemo" Then
                Screen.ActiveForm.Label4.Caption = "Ctrl_MouseMove:         Button=" & Button & " Shift=" & Shift & " X=" & X & " Y=" & Y
            End If
        Case "VScroll1"
            If Button = 1 Then
                Dim Hdemilabel As Long, Tlabel As Long
                Dim ConverY As Long
                Hdemilabel = Screen.ActiveForm.Label2.Height / 2
                ConverY = Screen.ActiveForm.ScaleY(Y, vbPixels, Screen.ActiveForm.ScaleMode)
                ConverY = ConverY - Hdemilabel
                Tlabel = Screen.ActiveForm.VScroll1.Top + ConverY
                Screen.ActiveForm.Label2.Top = Tlabel
            End If
        'Case "autre composant"
        'Case "autre ....."
    End Select
    End Sub
    Private Sub Ctrl_MouseUp(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
    Select Case QuelCtrl.Name
        Case "HScroll1"
           If Shift = 4 Then Screen.ActiveForm.HScroll1.LargeChange = 1
        'Case "autre composant"
        'Case "autre ....."
    End Select
    End Sub
    Private Sub Ctrl_MouseSortie(QuelCtrl As Control)
    'le curseur de la souris vient de sortire de la surface du contrôle
    With Screen.ActiveForm
        Select Case QuelCtrl.Name
            Case "HScroll1": .Label1.Visible = False
            Case "VScroll1": .Label2.Visible = False
            Case "Picture1"
                'Gestion d'un même type de contrôle ayant le même nom mais sur 2 formulaires différents
                If .Name = "FormDemo" Then
                    .Picture1.Picture = LoadPicture(App.Path & "\Image1.jpg")
                    .Label3.Visible = False
                    .Label4.Visible = False
                    Else
                    'FormDemo2
                    .Picture1.Print "la souris vient de sortir"
                End If
        End Select
    End With
    End Sub
    Pour vos propres projets, vous devrez personnaliser les 5 Subs (début ligne 136) .


    Un premier Form avec 1 HScroll, 1 VScroll, 1 PictureBox et 5 Labels, renommer le Form FormDemo, laissez chaque composant par son nom par défaut.
    Pour le PictureBox, vous devez avoir 2 fichiers image (Image1.jpg et Image2.jpg de 80x80 pixels à peu prés) dans le même dossier que le projet.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    Option Explicit
     
    Private Sub Form_Load()
    Me.Caption = "FormDemo"
    Me.Height = 4095: Me.Width = 7935
     
    HScroll1.Move 120, 360, 2595, 315
    HScroll1.Min = 0: HScroll1.Max = 500
    Label1.Visible = False: Label1.Alignment = 2 'centré
    Label1.FontBold = True: Label1.AutoSize = True
    Label1.Move HScroll1.Left + ((HScroll1.Width - Label1.Width) / 2), HScroll1.Top - Label1.Height
    Label1.Caption = HScroll1.Value
     
    VScroll1.Move (HScroll1.Left + HScroll1.Width) - 435, HScroll1.Top + HScroll1.Height, 435, 2535
    VScroll1.Min = 0: VScroll1.Max = 1500
    Label2.Visible = False: Label2.Alignment = 2 'centré
    Label2.FontBold = True: Label2.AutoSize = True
    Label2.Move VScroll1.Left + VScroll1.Width, VScroll1.Top
    Label2.Caption = VScroll1.Value
     
    Label3.Visible = False: Label3.AutoSize = True
    Label3.Move 3420, 120
     
    Label4.Visible = False: Label4.AutoSize = True
    Label4.Move 3420, 360
     
    Picture1.AutoSize = True: Picture1.BorderStyle = 0
    Picture1.Picture = LoadPicture(App.Path & "\Image1.jpg")
    Picture1.Move 3420, 600
     
    Label5.Move 120, 3240: Label5.AutoSize = True: Label5.Caption = "Dbl. cliquez pour ouvrir l'autre Form"
     
    '*************************************************************************************************
    '**** on crée un timer qui va permetre la surveillance et la simulation des évènements souris ****
    SetTimer Me.hwnd, 0, 100, AddressOf SurveillanceMouse '                                       ****
    '*************************************************************************************************
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
    '******************************************************************************
    KillTimer Me.hwnd, 0  'supprimer le timer '                                ****
    '******************************************************************************
    'éventuellement fermer l'autre formulaire
    If Forms.Count = 2 Then Unload FormDemo2
    End Sub
     
    Private Sub Form_DblClick()
    FormDemo2.Show
    End Sub
    Private Sub Label5_DblClick()
    FormDemo2.Show
    End Sub
     
    Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Label3.Caption = "Picture1_MouseMove: Button=" & Button & " Shift=" & Shift & " X=" & X & " Y=" & Y
    End Sub
    Private Sub HScroll1_Change()
    Label1.Caption = " " & HScroll1.Value & " "
    End Sub
    Private Sub HScroll1_Scroll()
    HScroll1_Change
    End Sub
    Private Sub VScroll1_Change()
    Label2.Caption = " " & VScroll1.Value & " "
    End Sub
    Private Sub VScroll1_Scroll()
    VScroll1_Change
    End Sub
    Un deuxième Form avec 1 PictureBox et un Label, renommer le Form FormDemo2, laisser le PictureBox et label avec leur nom par défaut.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    Option Explicit
     
    Private Sub Form_Load()
    Me.Caption = "FormDemo2"
    Label1.Move 0, 0: Label1.Caption = "Dbl. cliquez pour effacer le texte"
    Picture1.AutoRedraw = True
    Picture1.Move 780, 300, 2895, 2175
    Me.Height = 3600: Me.Width = 4800
    End Sub
    Private Sub Form_DblClick()
    Picture1.Cls
    End Sub
    Private Sub Label1_DblClick()
    Picture1.Cls
    End Sub
    Vous pouvez aussi télécharger le ZIP Creation Evenements Mouse.zip
    Soyez sympa, pensez -y
    Balises[CODE]...[/CODE]
    Balises[CODE=NomDuLangage]...[/CODE] quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Balises[C]...[/C] code intégré dans une phrase.
    Balises[C=NomDuLangage]...[/C] code intégré dans une phrase quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Le bouton en fin de discussion, quand vous avez obtenu l'aide attendue.
    ......... et pourquoi pas, pour remercier, un pour celui/ceux qui vous ont dépannés.
    👉 → → Ma page perso sur DVP ← ← 👈

  2. #2
    Modérateur
    Avatar de ProgElecT
    Homme Profil pro
    Retraité
    Inscrit en
    Décembre 2004
    Messages
    6 067
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 67
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Communication - Médias

    Informations forums :
    Inscription : Décembre 2004
    Messages : 6 067
    Points : 17 152
    Points
    17 152
    Par défaut Un complément incluant la gestion de la rotation de la roulette de la souris.
    Salut

    Récupérer et agir sur l’utilisation de la rotation de la roulette pour déplacer les lignes et/ou les colonnes d’un DataGrid, FlexGrid et Hierarchical FlexGrid.
    Sur un Form 4 composants :
    1 DataGrid (Contrôle Microsoft DataGrid 6.0 (OLEDB) MSDATGRD.ocx)
    et son Adodc (Microsoft ADO Data Control 6.0 (OLEDB) MSADODC.ocx)
    1 MSFlexGrid (Contrôle Microsoft FlexGrid 6.0 MSFLXGRD.ocx)
    1 MSHFlexGrid (Microsoft Hierarchical FlexGrid Control 6.0 (OLEDB) MSHFLXGD.ocx)
    Ce
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    Option Explicit
     
    Dim T As Integer, U As Integer
     
    Private Sub Form_Load()
     
    '--------------- Contrôle Microsoft DataGrid 6.0 (OLEDB) MSDATGRD.ocx ------------
    DataGrid1.ToolTipText = " DataGrid "
    DataGrid1.Move 4560, 120, 4335, 1335
    '--------------- Microsoft ADO Data Control 6.0 (OLEDB) MSADODC.ocx ------------
    Adodc1.Move 4560, 1500, 4335, 435
    '************ ATTENTION ICI modifiez le ConnectionString et le RecordSource suivant votre propre BDs ****************************
    'Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=I:\PersoFrancis novembre 2014\BDpourEssais.mdb;Persist Security Info=False"
    Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\PersoFrancis novembre 2014\BDpourEssais.mdb;Persist Security Info=False"
    Adodc1.RecordSource = "Principal"
    '********************************************************************************************************************************
    Set DataGrid1.DataSource = Adodc1
    '------------------------------------------------------------------------------
     
    '---------------- Contrôle Microsoft FlexGrid 6.0 MSFLXGRD.ocx ----------------
    MSFlexGrid1.ScrollBars = flexScrollBarBoth
    MSFlexGrid1.ToolTipText = " MSFlexGrid "
    MSFlexGrid1.Move 120, 2100, 4335, 3195
    MSFlexGrid1.Rows = 20
    MSFlexGrid1.FixedRows = 1
    MSFlexGrid1.Cols = 7
    MSFlexGrid1.FixedCols = 0
    'Histoire de remplir le grid
    MSFlexGrid1.FormatString = "colonne 1|colonne 2|colonne 3 |colonne 4|colonne 5|colonne 6|colonne 7" 'titrage des colonnes
    For T = 1 To MSFlexGrid1.Rows - 1
        For U = 0 To MSFlexGrid1.Cols - 1
            MSFlexGrid1.TextMatrix(T, U) = Chr(64 + T + U) 'remplis chaque celulle
        Next U
    Next T
     
    '------------------ Microsoft Hierarchical FlexGrid Control 6.0 (OLEDB) MSHFLXGD.ocx -----------
    MSHFlexGrid1.ScrollBars = flexScrollBarBoth
    MSHFlexGrid1.ToolTipText = " MSHFlexGrid "
    MSHFlexGrid1.Move 4560, 2100, 4335, 3195
    MSHFlexGrid1.Rows = 20
    MSHFlexGrid1.FixedRows = 1
    MSHFlexGrid1.Cols = 7
    MSHFlexGrid1.FixedCols = 0
    'Histoire de remplir le grid
    MSHFlexGrid1.FormatString = "colonne 1|colonne 2|colonne 3 |colonne 4|colonne 5|colonne 6|colonne 7" 'titrage des colonnes
    For T = 1 To MSHFlexGrid1.Rows - 1
        For U = 0 To MSHFlexGrid1.Cols - 1
            MSHFlexGrid1.TextMatrix(T, U) = Chr(64 + T + U) 'remplis chaque celulle
        Next U
    Next T
     
    Me.AutoRedraw = True
    Me.Print " Action roulette sur l'un des grids:"
    Me.Print
    Me.Print "   vers le haut, fait monter les lignes"
    Me.Print "   vers le bas, les faits descendre."
    Me.Print
    Me.Print "   Bt.  droit de la souris maintenu appuyé"
    Me.Print "   vers le haut, déplacement des lignes vers  la droite"
    Me.Print "   vers le bas, déplacement vers la gauche"
    Me.Height = MSFlexGrid1.Top + MSFlexGrid1.Height + MSFlexGrid1.Left + 480
    Me.Width = DataGrid1.Left + DataGrid1.Width + (MSFlexGrid1.Left * 3)
     
    '**** on crée un timer qui va permetre la surveillance et la simulation des évènements souris ****
    SetTimer Me.hWnd, 0, 100, AddressOf SurveillanceMouse  '                                      ****
    '*************************************************************************************************
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
    '*********************************************
    KillTimer Me.hWnd, 0  'supprimer le timer ****
    '*********************************************
    End Sub
    ATTENTION vous devez personnaliser les lignes 14 et 15.
    L’idéale serait de pointer vers une BDs d’au moins 6 enregistrements et au moins 6 champs.

    Dans un module .bas, ce
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    282
    283
    284
    285
    286
    287
    288
    289
    290
    291
    292
    293
    294
    295
    Option Explicit
    '*********************** Module permettant de récupérer la rotation de la roulette souris et ******************
    '*********************** de créer des événements suivant la position du curseur de la souris *****************
    '--- prés requis ---------------------------------------------------------------------------------------------
    '---------- le composant pour lequel on veux créer l'événement et/ou récupérer la rotation roulette ----------
    '---------------------- doit impérativement avoir la propriété Hwnd ------------------------------------------
    '-------------------------------------------------------------------------------------------------------------
     
    '/////////////////////// Partie événements souris \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    'Récupère la position du curseur, en coordonnées d'écran.
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    'Récupère le handle de la fenêtre qui contient le point spécifié.
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    'Récupère le handle de la fenêtre parent de la fenêtre enfant spécifié.
    Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
    Dim Pxy As POINTAPI
     
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    'Récupère les dimensions du rectangle de la fenêtre spécifiée.
    'Les dimensions sont indiquées en coordonnées d'écran qui sont relatives au coin supérieur gauche de l'écran.
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
     
    'Pour lire les touches du clavier
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
     
    'Pour surveiller le curseur de la souris
    'Crée une minuterie avec la valeur de délai d'attente spécifié.
    Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
                                                   ByVal nIDEvent As Long, ByVal uElapse As Long, _
                                                   ByVal lpTimerFunc As Long) As Long
    'Détruit la minuterie spécifiée.
    Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
     
    'variables pour gérer les évènements et paramètres.
    Dim OldCtrlActiver As String, CtrlActiver As String, CtrlAsurveiller As Boolean
    Dim MemoBtPresser As Integer, MemoShift As Integer
     
    '/////////////////////// Partie événements roulette de la souris \\\\\\\\\\\\\\\\\\\\\\\\\\
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
    Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" ( _
        ByVal hWnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
    Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
        ByVal lpPrevWndFunc As Long, _
        ByVal hWnd As Long, _
        ByVal Msg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
        ByVal hWnd As Long, _
        ByVal lpString As String) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
        ByVal hWnd As Long, _
        ByVal lpString As String, _
        ByVal hData As Long) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _
        ByVal hWnd As Long, _
        ByVal lpString As String) As Long
    Private Declare Function GetSystemMetrics Lib "user32" ( _
        ByVal nIndex As Long) As Long
    Private Const SM_MOUSEWHEELPRESENT = 75
    Private Const WM_MOUSEWHEEL = &H20A
    Private Const WHEEL_DELTA = 120
    Private Const GWL_WNDPROC = (-4)
    Dim RoueCentrale As Boolean
     
    Private Sub Main()
    'prend la valeur True si La souris reliée à l'ordinateur a une roulette
    RoueCentrale = CBool(GetSystemMetrics(SM_MOUSEWHEELPRESENT))
    Form1.Show
    End Sub
     
    '/////////////////////// Partie événements roulette de la souris \\\\\\\\\\\\\\\\\\\\\\\\\\
    Private Function HiWord(dw As Long) As Integer
    If dw And &H80000000 Then HiWord = (dw \ 65535) - 1 Else HiWord = dw \ 65535
    End Function
    Private Function SurveillanceRoulette(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'cette fonction n'est enclenchée que si la partie "SurveillanceMouse" est sur un contrôle a traiter et sera arrêté par le même procès
    Dim TheCtrl As Control, Result As Integer
     
    Set TheCtrl = Screen.ActiveControl
    If uMsg = WM_MOUSEWHEEL Then ' la roulette a été utilisée
        Result = HiWord(wParam) / WHEEL_DELTA '-1 ou 1
        Select Case TypeName(TheCtrl)
            Case "MSFlexGrid", "MSHFlexGrid"
                'MemoBtPresser = vbRightButton = agir sur le défilement des colonnes
                If Result < 0 Then '-1
                    If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
                        TheCtrl.LeftCol = TheCtrl.LeftCol + 1
                        Else 'agir sur le défilement des lignes
                        TheCtrl.TopRow = TheCtrl.TopRow + 1
                    End If
                    Else '1
                    If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
                        If TheCtrl.LeftCol > TheCtrl.FixedCols Then TheCtrl.LeftCol = TheCtrl.LeftCol - 1
                        Else 'agir sur le défilement des lignes
                        If TheCtrl.TopRow > TheCtrl.FixedRows Then TheCtrl.TopRow = TheCtrl.TopRow - 1
                    End If
                End If
            Case "DataGrid"
                If Result < 0 Then
                    If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
                        TheCtrl.Scroll 1, 0
                        Else 'agir sur le défilement des lignes
                        TheCtrl.Scroll 0, 1
                    End If
                    Else
                    If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
                        TheCtrl.Scroll -1, 0
                        Else 'agir sur le défilement des lignes
                        TheCtrl.Scroll 0, -1
                    End If
                End If
        End Select
        'Passez le message au procédé de fenêtre de défaut et puis sur le parent
        DefWindowProc hWnd, uMsg, wParam, lParam
        Else
        'Message manipulé, n'appelle pas le procédé original de fenêtre
        SurveillanceRoulette = CallWindowProc(GetProp(TheCtrl.hWnd, "PrevWndProc"), hWnd, uMsg, wParam, lParam)
    End If
    Set TheCtrl = Nothing
    End Function
    Private Sub DemarerSurveillanceRoulette(Controle As Control)
    'Crée/enclenche, en tache de fond, la surveillance de la de la roulette souris, enclenché par "SurveillanceMouse"
    SetProp Controle.hWnd, "PrevWndProc", SetWindowLong(Controle.hWnd, GWL_WNDPROC, AddressOf SurveillanceRoulette)
    End Sub
    Private Sub FinSurveillanceRoulette(Controle As Control)
    'pour mettre fin proprement à la routine utilisation de la roulette souris, enclenché par "SurveillanceMouse"
    SetWindowLong Controle.hWnd, GWL_WNDPROC, GetProp(Controle.hWnd, "PrevWndProc")
    RemoveProp Controle.hWnd, "PrevWndProc"
    End Sub
     
     
    '/////////////////////// Partie événements souris \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    Public Sub SurveillanceMouse()
    Dim HwndLut As Long
    'surveillance du déplacement du curseur de la souris
    GetCursorPos Pxy 'Obtention de la position actuelle de la souris
    HwndLut = WindowFromPoint(Pxy.X, Pxy.Y) 'Obtention de la fenêtre sous la souris
    If Identification(HwndLut) = False Then
        'recherche du Hwnd parent par apport au Hwnd sous le curseur de la souris (exemple cas du ComboBox)
        If GetParent(HwndLut) <> 0 Then Identification GetParent(HwndLut)
        'Else
        'Identification(HwndLut) = True
        'un contrôle que l'on veut surveiller à été trouvé sous la souris
    End If
     
    'analyse suite au résultat de la recherche du composant sous le curseur de la souris
    If CtrlAsurveiller = True Then
        If CtrlActiver <> OldCtrlActiver Then
            'la souris vient de quitté un contrôle qui était surveillé
            LancerEventCtrl OldCtrlActiver, "Quitte"
            'la souris commence a passer au dessus du nouveau contrôle devant être surveillé
            LancerEventCtrl CtrlActiver, "Entre"
            OldCtrlActiver = CtrlActiver
        End If
    End If
    If CtrlAsurveiller = False Then
        If CtrlActiver <> "" Then 'la souris quitte le contrôle qui était surveillé
            LancerEventCtrl CtrlActiver, "Quitte"
            CtrlActiver = "": OldCtrlActiver = ""
            MemoBtPresser = 0: MemoShift = 0
        End If
    End If
    DoEvents
    End Sub
    Private Function Identification(HwndSoumis As Long) As Boolean
    Dim Lobjet As Control
    'parcour de tous les contrôles du Form
    For Each Lobjet In Screen.ActiveForm.Controls
        Select Case TypeName(Lobjet)
            'Sélection d'un composant qui n'a pas les évènements souris n'y l'évènements roulette et/ou
            'un composant qui n'a pas l'évènement entrée/sortie sur la surface du contrôle
            Case "MSFlexGrid", "MSHFlexGrid", "DataGrid"
                 If Lobjet.hWnd = HwndSoumis Then
                    Identification = True
                    CtrlActiver = Lobjet.Name
                    RecupeParametres Lobjet
                    Exit For
                 End If
        End Select
    Next
    CtrlAsurveiller = Identification
    End Function
    Private Sub RecupeParametres(QuelCtrl As Control)
    'procédure pour récupération des informations a passer aux procédures Ctrl_MouseDown, Ctrl_MouseMove et Ctrl_MouseUp
    'MemoBtPresser et MemoShift peuvent aussi servir pour la procédure "SurveillanceRoulette"
     
    '--- Lecture des états et positionnement du curseur souris ---
    Dim XButton As Integer
    'détection d'un ou plusieurs boutons en appuis
    If GetAsyncKeyState(vbLeftButton) <> 0 Then XButton = vbLeftButton
    If GetAsyncKeyState(vbRightButton) <> 0 Then XButton = XButton + vbRightButton
    If GetAsyncKeyState(vbMiddleButton) <> 0 Then XButton = XButton + vbMiddleButton
     
    'Shift = MAJ, CTRL et ALT
    Dim XShift As Integer
    'détection d'une ou plusieurs touches du clavier en appuis
    If GetAsyncKeyState(vbKeyShift) <> 0 Then XShift = vbShiftMask
    If GetAsyncKeyState(vbKeyControl) <> 0 Then XShift = XShift + vbCtrlMask
    If GetAsyncKeyState(vbKeyMenu) <> 0 Then XShift = XShift + vbAltMask
     
    Dim Rectangle As RECT, PosX As Long, PosY As Long
    'récupération des cordonnées du curseur souris en référence du coin haut à gauche du contrôle
    GetWindowRect QuelCtrl.hWnd, Rectangle
    PosX = Pxy.X - Rectangle.Left: PosY = Pxy.Y - Rectangle.Top
     
    '--- Enclenchement de la procédure évènement appropriée ---
    If CtrlActiver = OldCtrlActiver Then
        If XButton > MemoBtPresser And XButton <> 0 Then
            Ctrl_MouseDown QuelCtrl, XButton, XShift, PosX, PosY
        End If
        If XButton = MemoBtPresser Then
            Ctrl_MouseMove QuelCtrl, XButton, XShift, PosX, PosY
        End If
        If XButton < MemoBtPresser Then
            Ctrl_MouseUp QuelCtrl, XButton, XShift, PosX, PosY
        End If
    End If
     
    MemoBtPresser = XButton: MemoShift = XShift
     
    End Sub
    Private Sub LancerEventCtrl(NomDuCtrl As String, procédureAlancer As String)
    'parcour de tous les contrôles du Form pour pouvoir enclancher les procedures Entrée ou Sortie de la surface du composont
    Dim Lobjet As Control
    For Each Lobjet In Screen.ActiveForm.Controls
        If Lobjet.Name = NomDuCtrl Then
            If procédureAlancer = "Entre" Then Ctrl_MouseEntrer Lobjet Else Ctrl_MouseSortie Lobjet
            Exit For
        End If
    Next
    End Sub
     
     
     
    '---------------------------- Les 5 procédures d'évènements souris pour les contrôles n'en ayant pas ---------------------------
    Private Sub Ctrl_MouseEntrer(QuelCtrl As Control)
    'le curseur de la souris entre sur la surface du contrôle (ne se produit qu'une seule fois)
    Select Case QuelCtrl.Name
        Case "MSFlexGrid1", "MSHFlexGrid1", "DataGrid1"
            'pour chacun de ces composants je désire faire bouger les cellules avec la roulette de la souris
            QuelCtrl.SetFocus
            If RoueCentrale Then DemarerSurveillanceRoulette QuelCtrl 'activation de la surveillance de la roulette
            'pour le DataGrid il faut sortir de l'édition de la cellule
            If QuelCtrl.Name = "DataGrid1" Then QuelCtrl.EditActive = False
    '    Case "autre nom d'un composant"
    '    Case "autre ....."
    End Select
    End Sub
    Private Sub Ctrl_MouseDown(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
    'X et Y sont dans l'unité Pixels, c'est voulu pour être utilisé par les APIs
    'Select Case QuelCtrl.Name
    '    Case "Nom du composant"
    '    Case "autre nom d'un composant"
    '    Case "autre ....."
    'End Select
    End Sub
    Private Sub Ctrl_MouseMove(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
    'Select Case QuelCtrl.Name
    '    Case "Nom du composant"
    '    Case "autre nom d'un composant"
    '    Case "autre ....."
    'End Select
    End Sub
    Private Sub Ctrl_MouseUp(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
    'Select Case QuelCtrl.Name
    '    Case "Nom du composant"
    '    Case "autre nom d'un composant"
    '    Case "autre ....."
    'End Select
    End Sub
    Private Sub Ctrl_MouseSortie(QuelCtrl As Control)
    'le curseur de la souris vient de sortir de la surface du contrôle (ne se produit qu'une seule fois)
    Select Case QuelCtrl.Name
        Case "MSFlexGrid1", "MSHFlexGrid1", "DataGrid1"
            If RoueCentrale Then FinSurveillanceRoulette QuelCtrl
    '    Case "autre nom d'un composant"
    '    Case "autre ....."
    End Select
    End Sub
    Vous pouvez aussi télécharger le ZIP
    Fichiers attachés Fichiers attachés
    Soyez sympa, pensez -y
    Balises[CODE]...[/CODE]
    Balises[CODE=NomDuLangage]...[/CODE] quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Balises[C]...[/C] code intégré dans une phrase.
    Balises[C=NomDuLangage]...[/C] code intégré dans une phrase quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Le bouton en fin de discussion, quand vous avez obtenu l'aide attendue.
    ......... et pourquoi pas, pour remercier, un pour celui/ceux qui vous ont dépannés.
    👉 → → Ma page perso sur DVP ← ← 👈

Discussions similaires

  1. Ajouter un évènement dans mon composant calendrier
    Par smallville1993 dans le forum AWT/Swing
    Réponses: 7
    Dernier message: 13/01/2016, 12h35
  2. Réponses: 20
    Dernier message: 17/09/2015, 10h05
  3. Réponses: 2
    Dernier message: 09/05/2012, 17h16
  4. Réponses: 17
    Dernier message: 12/04/2007, 16h42
  5. Les modifications ne sont plus prises en compte
    Par yousfi.z dans le forum Eclipse Java
    Réponses: 3
    Dernier message: 28/03/2007, 12h51

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo