UTILISATION MOLETTE ROULETTE SOURIS

Commentaire de frop01 le 05/08/2004 21:30:51

Très utile Merci :)

Commentaire de trabice le 29/09/2004 10:25:44

merci bcp.pour cette belle source qui marche.
c tout ce kon lui demande..

Commentaire de Philippe734 le 08/12/2004 22:47:41

tu l'a référencie ds le projet, un peu comme une dll

Commentaire de tibi055 le 01/04/2005 11:01:23

cool mais fonctionne pas si le contrôle est dans une fenêtre de type MDI Child.

Commentaire de Philippe734 le 19/04/2005 19:45:50

avec certaine type de form (mdi child...), cela ne marche qu'une fois compilé. et je s'en sai rien pkoi

:)

Commentaire de jonathan02 le 24/05/2005 23:59:50

C'est bon j'ai trouver !
merci

Commentaire de PCPT le 12/08/2005 21:20:08 administrateur CS

salut,

petit souci, ne fonctionne pas en projet compilé. je suis le seul?
PCPT

Commentaire de njulio le 15/09/2005 19:47:24

Je ne sais pas à quel niveau il faut écrire :
Call ActiverMoletteEtDéfinirObjetScroll(Formulaire1.MSHFlexGrid1)

si "Formulaire1" est le nom de ma feuille.

Commentaire de SgtKabukinan le 22/09/2005 15:31:52

d'ailleurs à ce propos
si tu as deux form qui a un datagrid avec la molette activée
et que tu ouvres une autre form avec un datagrid en activant la molette,
la molette ne fonctionne pas dans la seconde (pas d'erreur), et ne fonctionne plus non plus dans la première form (erreur)
Avis au amateurs

Commentaire de yoh_bur le 18/10/2005 15:44:53

Merci de ce code.
J'ai par contre un petit probleme avec. Je l'avais utilisé lors du developpement d'une appli sur mon fixe, il n'y avait aucun probleme (le fixe est sous XP).
Aujourd'hui, je reprends la meme appli sur un portable (aussi sous XP). Apres une copie du projet sur le dur du portable, je lance le projet. Je verifie que wheel.tb est bien declaré, et je lance une execution pour voir.
Il me mets alors: "projet ou bibliotheque introuvable" et plante sur la fonction RegOpenKey.
Pourriez vous me dire pourquoi?

Commentaire de chris81 le 25/01/2006 11:52:33

bonjour,
je suis en train de tester ton code et il me retourne un erreur ici

    If RegOpenKey(HKEY_CURRENT_USER, HKEYDESKTOP, hKey) Then... il me dit procedure sub ou function on définie.
Saurais tu d'ou peux venir ce pb?

Commentaire de SgtKabukinan le 26/01/2006 11:32:32

D'ailleurs mieux vaut mettre la déclaration dans le onfocus du grid
Call ActiverMoletteEtDéfinirObjetScroll(frm.grid)
et celle la dans le lostFocus
Call DesactiverMolette

Pour éviter tout problème

Commentaire de Rrominet le 14/02/2006 17:03:51

Tout bonnement géniale cette source !!!

Moi qui me voyait déjà galéré des heures sur le sujet, pour finir ça m'a pris 3 minutes chrono en main pour intégrer ta source de partout :-)


Merciiiiiiiiiiiiii !!

Commentaire de michpirm le 03/08/2006 16:26:15

Bonjour,

Merci pour ces lignes de codes qui fonctionnent bien.

J'ai juste un petit problème :

Si dans mes lignes de codes autres que les lignes de ce petit programme, j'ai un message erreur de débogage, de VB6 ce qui est normal, mais dès que je clique sur la fin du débogage, VB6 se ferme et ce depuis que j'ai installé ce programme pour la roulette de la souris.

Obligé de la relancer VB6!!??

Quelqu'un à la solution?

Michel

Commentaire de Rrominet le 03/11/2006 13:17:14

J'ai aussi le problème sur un ordi où la molette ne fonctionne pas malgré ce code...
Et d'autres ordis où cela fonctionne nickel !!

Sinon juste pour info, pas mal de contrôles que j'ai pu créer ou réutiliser me plantent VB6.
Ca devient monnaie courante quand l'appli en utilise beaucoup ou est trop grosse. Sans doute qu'il y a des choses à ne pas faire en dev et qui font planter VB...

Le fait de passer de Win98 à WinXP m'avait permi à l'époque d'éviter beaucoup de plantages de VB, mais il en reste trop...

Commentaire de med_sp2 le 07/09/2007 12:19:43

merci beaucoup

Commentaire de andalo le 26/09/2007 03:03:06

c'est ragant, ne veux plus fonctioner une fois compilé!! j'ai vu que d'autres personnes ont ce souci, je maitrise pas assez pour ne trouver la cause.

Commentaire de pascamau le 05/06/2009 15:24:17

Super !
Ajout de la fonctionnalité Wheel en 30 secondes sur un MSFlexGrid sous VB6 portable,
et ça fonctionne en version compilée.
Merci.

Commentaire de bingo_bechir le 09/09/2009 13:46:28

je suis très triste car c'est ca ne fonctionne pas chez moi, svp aidez moi.
c'est urgent

Commentaire de asimengo le 12/02/2010 10:40:38

merci beaucoup pour ce code, j'ai été obligé de m'y plonger, vu que j'ai une préférence pour le datagrid et c pas top de voir qu'on soit le seul à ne pas bénéficier de la molette dans ses applis au 21ème siècle.

Ci-dessous le module "Molette.bas" que j'ai retouché et adapter spécifiquement pour le Datagrid.
Vu que la recherche de la fenetre contenant le Datagrid était un peu à taton ici , j'ai ajouté un paramètre permettant de passer la hwnd du parent.

Option Explicit
'
' Original Idea From
' :) Ulli's VBMouseWheel (10.09.2002)
' then
' codé par EBArtSoft@ (2004) : VB6 Wheel AddIn : ebartsoft@hotmail.com
' pour activer la molette dans l'éditeur de VB6, y avait un copyright
' then
' modifié par philippe734 pour l'activation de la molette
' d'un object ayant :
' soit deux scroll bar, vertical et horizontale de type
' .scroll(cols as long, rows as long) (datagrid par ex)
' soit de type
' .toprow as long (flexgrid par ex)
' Rq : Référencer le fichier Wheel.tlb de EBArtSoft@
'

Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_MOUSEWHEEL As Long = &H20A

Private Const PRPNAME As String = "WheelPrc"
Private Const m_def_DefaultLines As Long = 3


Private moDataGrid As Datagrid, mlLines As Long
Private mbWheelEnabled As Boolean
Private mhWnd As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
   (ByVal hWnd As Long, ByVal lpClassName As String, _
   ByVal nMaxCount As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
   (ByVal hWnd As Long, ByVal lpString As String, _
   ByVal cch As Long) As Long

Public Sub LoadDatagrid(ByRef poDataGrid As Datagrid, Optional ByVal plParenthWnd As Long = 0, Optional ByVal plLines As Long = m_def_DefaultLines)
   Dim lRetVal As Long
   Dim sWinClassBuf As String * 255, sWinTitleBuf As String * 255
   Dim sWinClass As String, sWinTitle As String

    If plParenthWnd <> 0 Then
        lRetVal = GetClassName(plParenthWnd, sWinClassBuf, 255)
        sWinClass = StripNulls(sWinClassBuf)  ' remove extra Nulls & spaces
        lRetVal = GetWindowText(plParenthWnd, sWinTitleBuf, 255)
        sWinTitle = StripNulls(sWinTitleBuf)
        mhWnd = FindWindow(sWinClass, sWinTitle)
    Else
        'test si la fenetre est de class ThunderFormDC
        mhWnd = FindWindow("ThunderFormDC", vbNullString)
        
        'test si la fenetre est de class ThunderRT6FormDC (form vb6 une fois compilé)
        If mhWnd = 0 Then mhWnd = FindWindow("ThunderRT6FormDC", vbNullString)
        
        'test si la fenetre est de class MDIClient
        If mhWnd = 0 Then mhWnd = FindWindow("MDIClient", vbNullString)
    End If
    
    Set moDataGrid = poDataGrid
    mlLines = plLines
End Sub

Public Function GetWheelStatus() As Boolean
    GetWheelStatus = mbWheelEnabled
End Function

Public Sub SetWheelStatus(ByVal pbEnabledWheel As Boolean)
    If mbWheelEnabled Then Call UnhookWindow
    If pbEnabledWheel Then Call HookWindow
End Sub


Private Function StripNulls(ByRef psOriginalStr As String) As String
   ' This removes the extra Nulls so String comparisons will work
   If (InStr(psOriginalStr, Chr(0)) > 0) Then
      psOriginalStr = Left(psOriginalStr, InStr(psOriginalStr, Chr(0)) - 1)
   End If
   StripNulls = psOriginalStr
End Function

Private Sub HookWindow()
    If mhWnd = 0 Then
        'Prise en charge de la molette impossible
        mbWheelEnabled = False
    Else
        SetProp mhWnd, PRPNAME, GetWindowLong(mhWnd, GWL_WNDPROC)
        SetWindowLong mhWnd, GWL_WNDPROC, AddressOf WindowProc
        mbWheelEnabled = True
    End If
End Sub

Private Sub UnhookWindow()
Dim mWndProc As Long
    
    mWndProc = GetProp(mhWnd, PRPNAME)
    If mWndProc <> 0 Then
        RemoveProp mhWnd, PRPNAME
        SetWindowLong mhWnd, GWL_WNDPROC, mWndProc
        Set moDataGrid = Nothing
    End If
    mbWheelEnabled = False
End Sub

Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lWndProc As Long, lScrollTo As Long

    lWndProc = GetProp(hWnd, PRPNAME)
    If lWndProc <> 0 Then
        WindowProc = CallWindowProc(lWndProc, hWnd, uMsg, wParam, lParam)
        'wParam indique le mouvement de la molette
        'pour wParam négatif, c'est pour voir en haut
        'positif, on descend le curseur du scrollbar
    
        Select Case uMsg
            Case WM_MOUSEWHEEL
                WindowProc = 0
                lScrollTo = -Sgn(wParam) * mlLines / ((wParam And &HFFFF&) \ 4 + 1)   'compute new top line
                moDataGrid.Scroll 0, lScrollTo
        End Select
    End If
End Function


Mode d'emploi:
- Copier ce code dans un module
- Sur la form contenant le datagrid, rajouter les lignes suivantes dans les évenements spécifiés:
  Private Sub Form_Load()
     LoadDatagrid DataGrid1, Me.hWnd
  End Sub

  Private Sub Form_Activate()
     SetWheelStatus True
  End Sub

  Private Sub Form_Unload(Cancel As Integer)
     SetWheelStatus False
  End Sub

Commentaire de asimengo le 14/02/2010 14:12:09

En definitive, j'ai du faire une source bien plus portable, voir http://www.vbfrance.com/codes/INTEGRATION-AUTOMATIQUE-ROULETTE-MOLETTE-SOURIS-DANS-VOS-APPLIS_51291.aspx