[VB6] MOLETTE SOURIS POUR DATAGRID, MSFLEXGRID ET MSHFLEXGRID
cs_frop01
Messages postés1352Date d'inscriptionlundi 27 octobre 2003StatutMembreDernière intervention19 novembre 2008
-
5 août 2004 à 21:30
yoanpg
Messages postés156Date d'inscriptiondimanche 15 février 2009StatutMembreDernière intervention20 janvier 2024
-
1 mai 2016 à 19:02
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
yoanpg
Messages postés156Date d'inscriptiondimanche 15 février 2009StatutMembreDernière intervention20 janvier 20243 1 mai 2016 à 19:02
Bonjour,
Super source, merci beaucoup.
Par contre j'ai un problème; J'ai réussi à la mettre en place sur une de mes Form, mais pas sur une autre. Je ne sais pas quelle peut être la différence entre mes 2 Form. J'ai bien copié les lignes dans la Déclaration, Initialise, Terminate et ISubclasser_WindowProc en changeant les noms des Form et DataGrid. Mais ça ne fonctionne pas :(
Une idée d'où ça peut venir ?
Merci d'avance
Philippe734
Messages postés308Date d'inscriptionlundi 16 décembre 2002StatutMembreDernière intervention15 juin 20151 12 août 2012 à 18:20
cs_lermite222
Messages postés492Date d'inscriptionjeudi 5 avril 2007StatutMembreDernière intervention 2 juillet 20124 12 août 2012 à 14:44
Ça fonctionne impec aussi en compiler.
J'ai un peu améliorer la sélection, je trouvais dommage de devoir cliquer sur le contrôle pour que le scroll fonctionne.
La constante WM_MOUSEFIRST permet de savoir si la souris survole le contrôle, j'ai donc modifié en ce sens...
Ajouter 3 variables dans la déclaration de la forme
Private mHwnd1 As Long 'mémorise le hwnd des contrôles pour les activés
Private mHwnd2 As Long
Private mHwnd3 As Long
dans la procédure Form_Initialize() j'ai ajouter
mHwnd1 = DataGrid1.hwnd
mHwnd2 = MSFlexGrid1.hwnd
mHwnd3 = MSHFlexGrid1.hwnd
et dans la fonction ISubclasser_WindowProc
Static MMhwnd As Long
If uMsg = WM_MOUSEFIRST Then
If MMhwnd <> hwnd Then
Select Case hwnd
Case mHwnd1: DataGrid1.SetFocus
Case mHwnd2: MSFlexGrid1.SetFocus
Case mHwnd3: MSHFlexGrid1.SetFocus
End Select
MMhwnd = hwnd
End If
Exit Function
End If
De cette façon la roulette agit sur le contrôle survoler. (je trouve plus pratique)
Juste un tit problème, ça fonctionne pas sur le premier contrôle tant que l'ont n'a pas cliquer une fois dessus ? et j'ai pas trouvé pourquoi.
Pour l'erreur des scroll, bien que j'aime pas tellement ça, j'ai mis un On Error Resume Next.
J'ai aussi ajouter 2 constantes dans l'Enum
WM_MOUSEGAUCHEDROIT = &H20E 'Roulette à gauche et droite
WM_MOUSEBUTTONSUPP = &H20B 'Boutons supplémentaires 4 et 5 de la souris
avec deux constantes pour wParam (pas dans l'Enum)
Public Const BUTTONSUPLEFT = &H20 'Valeur de wParam pour différencier les 2 boutons
Public Const BUTTONSUPRIGHT = &H40 'supplémentaires voir WM_MOUSEBUTTONSUPP
Y aurait-il un lien qui donne une explication sur toutes les constantes ?
Leurs utilités et fonctionnement. ?
En tout cas, c'est nickel, merci également à RendField pour la classe.
A+
cs_lermite222
Messages postés492Date d'inscriptionjeudi 5 avril 2007StatutMembreDernière intervention 2 juillet 20124 11 août 2012 à 13:19
Bonjour,
Parfait, enfin presque, il faudrait contrôler les valeurs renvoyées aux scroll, tombe très vite en erreur au déplacement de la molette.
Mais ça je pense que c'est à la portée de tous.
A part ça tu est trop modeste, c’est valable pour tout contrôles ayant un hwnd, y compris la forme.
Egalement utile pour détecter tout les boutons de la souris.
Bravo et merci.
A+
PS: pas encore tester en compiler.
Philippe734
Messages postés308Date d'inscriptionlundi 16 décembre 2002StatutMembreDernière intervention15 juin 20151 2 juin 2012 à 22:16
Mise à jour : projet complètement refait.
Tous les commentaires avant 2011 concernent l'ancienne version.
Philippe734
Messages postés308Date d'inscriptionlundi 16 décembre 2002StatutMembreDernière intervention15 juin 20151 27 juil. 2010 à 23:48
Depuis que j'ai découvert les modules de renfield pour subclasser (vbfrance.com/codes/MODULE-SUBCLASSER_38442.aspx), je n'utilise plus ma source. J'utilise ses modules dont le code de prise en charge de la molette pour une datagrid donne :
Private Function ISubclasser_WindowProc(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long) As Long
If hWnd <> mtWin1.hWnd Then Exit Function
ISubclasser_WindowProc = CallOldProc(mtWin1, hWnd, uMsg, wParam, lParam)
If uMsg = WM_MOUSEWHEEL Then Form1.DataGrid1.Scroll 0, 3 * Sgn(-wParam)
End Function
cs_asimengo
Messages postés280Date d'inscriptionjeudi 24 mars 2005StatutMembreDernière intervention18 mars 2009 14 févr. 2010 à 14:12
Private Const GWL_WNDPROC As Long = (-4)
Private Const m_def_DefaultLines As Long = 3
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 Property Set Datagrid(Optional ByVal plParenthWnd As Long 0, Optional ByVal plLines As Long m_def_DefaultLines, ByRef poDataGrid As Datagrid)
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 MDIClient If mhWnd 0 Then mhWnd FindWindow("MDIClient", vbNullString)
End If
Set moDataGrid = poDataGrid
mlLines = plLines
End Property
Public Property Get EnabledWheel() As Boolean
EnabledWheel = mbWheelEnabled
End Property
Public Property Let EnabledWheel(ByVal pbEnabledWheel As Boolean)
If mbWheelEnabled Then Call UnhookWindow
If pbEnabledWheel Then Call HookWindow
End Property
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
End If
mbWheelEnabled = False
End Sub
Private Sub Class_Terminate()
Set moDataGrid = Nothing
End Sub
Public Const PRPNAME As String = "WheelPrc"
Public moDataGrid As Datagrid, mlLines As Long
Public 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
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:
Dans votre Form contenant le datadrid1 mettre le code suivant
Option Explicit
Private moCls As Class1
Private Sub Form_Activate()
moCls.EnabledWheel = True
' SetWheelStatus True
End Sub
Private Sub Form_Load()
Set moCls.Datagrid(Me.hWnd) = DataGrid1
' LoadDatagrid DataGrid1, Me.hWnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
moCls.EnabledWheel = False
' SetWheelStatus False
End Sub
Private Sub Form_Initialize()
Set moCls = New Class1
End Sub
Private Sub Form_Terminate()
Set moCls = Nothing
End Sub
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 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
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
Private Sub Form_Activate()
SetWheelStatus True
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetWheelStatus False
End Sub
bingo_bechir
Messages postés7Date d'inscriptionmardi 16 mai 2006StatutMembreDernière intervention12 septembre 2009 12 sept. 2009 à 09:19
finalement je suis arrivé
merci Philippe734
bingo_bechir
Messages postés7Date d'inscriptionmardi 16 mai 2006StatutMembreDernière intervention12 septembre 2009 9 sept. 2009 à 13:46
je suis très triste car c'est ca ne fonctionne pas chez moi, svp aidez moi.
c'est urgent
cortexminus
Messages postés16Date d'inscriptionmardi 17 mai 2005StatutMembreDernière intervention10 août 2011 18 juin 2009 à 09:13
Superbe fonctionnalité, mis en place en 1 min.
Dommage que je n'arrive pas à le faire marcher sur les 3 onglets d'un MSHFlexGrid.
Ca fonctionne uniquement sur le dernier onglet.
Merci !
pascamau
Messages postés4Date d'inscriptionvendredi 28 janvier 2005StatutMembreDernière intervention 5 juin 2009 5 juin 2009 à 15:24
Super !
Ajout de la fonctionnalité Wheel en 30 secondes sur un MSFlexGrid sous VB6 portable,
et ça fonctionne en version compilée.
Merci.
cs_Ouneufe
Messages postés60Date d'inscriptionmardi 4 septembre 2001StatutMembreDernière intervention19 janvier 2009 20 nov. 2007 à 10:05
magnifique, beaucoup mieux que ce que j'utilisais auparavant.
andalo
Messages postés102Date d'inscriptionlundi 23 avril 2007StatutMembreDernière intervention20 octobre 2012 26 sept. 2007 à 03:03
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.
Philippe734
Messages postés308Date d'inscriptionlundi 16 décembre 2002StatutMembreDernière intervention15 juin 20151 9 sept. 2007 à 18:18
pour désactiver la molette faite ceci dans une procédure de ce code :
call UnhookWindow
:)
med_sp2
Messages postés9Date d'inscriptionmercredi 11 avril 2007StatutMembreDernière intervention 5 décembre 2010 7 sept. 2007 à 12:19
merci beaucoup
andalo
Messages postés102Date d'inscriptionlundi 23 avril 2007StatutMembreDernière intervention20 octobre 2012 22 août 2007 à 23:43
la fete, j'adore cette source.
En bon debutant que je suis j'essaye de suivre ce conseil suivant :
"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 "
Le desactivermolette apparement n'existe pas, comment proceder??
Rrominet
Messages postés133Date d'inscriptionlundi 26 janvier 2009StatutMembreDernière intervention24 novembre 20141 3 nov. 2006 à 13:17
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...
mosquitout
Messages postés12Date d'inscriptiondimanche 26 octobre 2003StatutMembreDernière intervention 2 janvier 2013 3 nov. 2006 à 10:43
Idem, chez moi ca ne marche pas non plus avec les MsFlexGrid ! même compilé. (avec bien sur la dll Wheel.tb référencée)
michpirm
Messages postés1Date d'inscriptionjeudi 23 février 2006StatutMembreDernière intervention 1 novembre 2009 3 août 2006 à 16:26
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
Subierman
Messages postés3Date d'inscriptionmercredi 11 mai 2005StatutMembreDernière intervention23 juillet 2007 29 mai 2006 à 17:35
chez moi, ça marche pas avec les MSFlexgrid....
Rrominet
Messages postés133Date d'inscriptionlundi 26 janvier 2009StatutMembreDernière intervention24 novembre 20141 14 févr. 2006 à 17:03
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 !!
yohan_titi
Messages postés37Date d'inscriptionlundi 15 mars 2004StatutMembreDernière intervention 6 décembre 2006 6 févr. 2006 à 17:34
Merci beaucoup pour ce code !
Chez moi il a fonctionné du 1er coup. Je cherchais ce type de source pour une Msflexgrid et ça marche !!!
Encore mille fois merci
SgtKabukinan
Messages postés106Date d'inscriptionlundi 20 septembre 2004StatutMembreDernière intervention23 janvier 2010 26 janv. 2006 à 11: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
SgtKabukinan
Messages postés106Date d'inscriptionlundi 20 septembre 2004StatutMembreDernière intervention23 janvier 2010 26 janv. 2006 à 11:29
Rajoute la déclaration de l'API dans le module ne private sur tu t'en sers pas autre part
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
cs_chris81
Messages postés589Date d'inscriptionjeudi 2 octobre 2003StatutMembreDernière intervention29 avril 20082 25 janv. 2006 à 11:52
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?
yoh_bur
Messages postés24Date d'inscriptionmercredi 18 mai 2005StatutMembreDernière intervention 9 février 2007 18 oct. 2005 à 15:52
Merci de ce code.
J'ai par contre un petit problème avec lors du transfert de mon projet de mon fixe a mon portable (tout deux sous XP). Alors que tout fonctionne nickel sur le fixe, lorsque je lance le projet en execution sur le portable il m'annonce "projet ou bibliotheque introuvable".
J'ai pourtant bien declaré wheel.tb dans les references du projet (redeclaré apres copie).
Merci d'avance des reponses.
yoh_bur
Messages postés24Date d'inscriptionmercredi 18 mai 2005StatutMembreDernière intervention 9 février 2007 18 oct. 2005 à 15:44
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?
yoh_bur
Messages postés24Date d'inscriptionmercredi 18 mai 2005StatutMembreDernière intervention 9 février 2007 18 oct. 2005 à 15:41
Merci de ce code.
J'ai un petit problème que je ne comprends pas. J'ai developpé mon appli sur un fixe sur lequel la molette de la souris est tres bien prise en compte.
Je reprends aujourd'hui mon appli sur un portable, apres copie du projet (dans son ensemble) sur le portable, lorsque jele lance, il me dit bibliotheque introuvable (pour la fonction RegOpenKey). J'ai pourtant bien declaré le fichier wheel.tb dans les references. Merci d'avance de votre aide.
SgtKabukinan
Messages postés106Date d'inscriptionlundi 20 septembre 2004StatutMembreDernière intervention23 janvier 2010 22 sept. 2005 à 15:31
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
SgtKabukinan
Messages postés106Date d'inscriptionlundi 20 septembre 2004StatutMembreDernière intervention23 janvier 2010 22 sept. 2005 à 15:21
dans l'evenement Form_Load
njulio
Messages postés21Date d'inscriptionmardi 13 septembre 2005StatutMembreDernière intervention16 août 2011 15 sept. 2005 à 19:47
Je ne sais pas à quel niveau il faut écrire :
Call ActiverMoletteEtDéfinirObjetScroll(Formulaire1.MSHFlexGrid1)
si "Formulaire1" est le nom de ma feuille.
cs_Migs
Messages postés53Date d'inscriptionmercredi 3 décembre 2003StatutMembreDernière intervention21 janvier 2019 29 août 2005 à 21:19
Cette source est super, mais ça ne marche pas pour plusieurs objets...
PCPT
Messages postés13272Date d'inscriptionlundi 13 décembre 2004StatutMembreDernière intervention 3 février 201847 12 août 2005 à 21:20
salut,
petit souci, ne fonctionne pas en projet compilé. je suis le seul?
PCPT
JoePatent
Messages postés171Date d'inscriptionjeudi 30 janvier 2003StatutMembreDernière intervention20 juillet 2008 8 août 2005 à 22:04
Le tout est compilé et ça ne fonctionne pas.
Prise en charge impossible.
Il s'agit d'un formulaire child qui roule dans une MDI...
Avez-vous trouvé une solution ? Ce code est simple d'usage et j'aimerais vraiment l'implanter dans mes logiciels.
cs_jonathan02
Messages postés2Date d'inscriptionjeudi 16 novembre 2000StatutMembreDernière intervention24 mai 2005 24 mai 2005 à 23:59
C'est bon j'ai trouver !
merci
cs_jonathan02
Messages postés2Date d'inscriptionjeudi 16 novembre 2000StatutMembreDernière intervention24 mai 2005 24 mai 2005 à 23:24
Je débute en VB et j'aimerai savoir comment référencer le fichier Wheel.tlb.
Merci.
Philippe734
Messages postés308Date d'inscriptionlundi 16 décembre 2002StatutMembreDernière intervention15 juin 20151 19 avril 2005 à 19:45
avec certaine type de form (mdi child...), cela ne marche qu'une fois compilé. et je s'en sai rien pkoi
:)
econs
Messages postés4030Date d'inscriptionmardi 13 mai 2003StatutMembreDernière intervention23 décembre 200824 19 avril 2005 à 16:32
log2002> Même erreur chez moi. Pas moyen de faire fonctionner ce code avec MSFlexgrid et MSHFlexgrid. Snif ...
Mais avec les autres contrôles, çà va.
tibi055
Messages postés2Date d'inscriptionjeudi 17 février 2005StatutMembreDernière intervention16 août 2005 1 avril 2005 à 11:01
cool mais fonctionne pas si le contrôle est dans une fenêtre de type MDI Child.
log2002
Messages postés29Date d'inscriptionmardi 1 avril 2003StatutMembreDernière intervention30 décembre 2004 30 déc. 2004 à 12:35
salut à tous,
j'ai un message d'error :
"prise en charge de la molette impossible"
c'est du à quoi ?
merci
Philippe734
Messages postés308Date d'inscriptionlundi 16 décembre 2002StatutMembreDernière intervention15 juin 20151 8 déc. 2004 à 22:47
tu l'a référencie ds le projet, un peu comme une dll
cs_zinoub
Messages postés1Date d'inscriptionmercredi 11 février 2004StatutMembreDernière intervention 8 décembre 2004 8 déc. 2004 à 17:49
Bonjour ,
comment faites vous pour charger l'api wheel.tlb? il me semble que j'ai un petit souci de chargement
merci pour votre aide!
cs_trabice
Messages postés328Date d'inscriptionmercredi 26 novembre 2003StatutMembreDernière intervention24 novembre 20051 29 sept. 2004 à 10:25
merci bcp.pour cette belle source qui marche.
c tout ce kon lui demande..
cs_sam013
Messages postés75Date d'inscriptionsamedi 27 mars 2004StatutMembreDernière intervention 4 juillet 2005 5 août 2004 à 21:43
Ah ça c'est bien :)
cs_frop01
Messages postés1352Date d'inscriptionlundi 27 octobre 2003StatutMembreDernière intervention19 novembre 20082 5 août 2004 à 21:30
1 mai 2016 à 19:02
Super source, merci beaucoup.
Par contre j'ai un problème; J'ai réussi à la mettre en place sur une de mes Form, mais pas sur une autre. Je ne sais pas quelle peut être la différence entre mes 2 Form. J'ai bien copié les lignes dans la Déclaration, Initialise, Terminate et ISubclasser_WindowProc en changeant les noms des Form et DataGrid. Mais ça ne fonctionne pas :(
Une idée d'où ça peut venir ?
Merci d'avance
12 août 2012 à 18:20
http://msdn.microsoft.com/en-us/library/windows/desktop/ms646260%28v=vs.85%29.aspx
12 août 2012 à 14:44
J'ai un peu améliorer la sélection, je trouvais dommage de devoir cliquer sur le contrôle pour que le scroll fonctionne.
La constante WM_MOUSEFIRST permet de savoir si la souris survole le contrôle, j'ai donc modifié en ce sens...
Ajouter 3 variables dans la déclaration de la forme
Private mHwnd1 As Long 'mémorise le hwnd des contrôles pour les activés
Private mHwnd2 As Long
Private mHwnd3 As Long
dans la procédure Form_Initialize() j'ai ajouter
mHwnd1 = DataGrid1.hwnd
mHwnd2 = MSFlexGrid1.hwnd
mHwnd3 = MSHFlexGrid1.hwnd
et dans la fonction ISubclasser_WindowProc
Static MMhwnd As Long
If uMsg = WM_MOUSEFIRST Then
If MMhwnd <> hwnd Then
Select Case hwnd
Case mHwnd1: DataGrid1.SetFocus
Case mHwnd2: MSFlexGrid1.SetFocus
Case mHwnd3: MSHFlexGrid1.SetFocus
End Select
MMhwnd = hwnd
End If
Exit Function
End If
De cette façon la roulette agit sur le contrôle survoler. (je trouve plus pratique)
Juste un tit problème, ça fonctionne pas sur le premier contrôle tant que l'ont n'a pas cliquer une fois dessus ? et j'ai pas trouvé pourquoi.
Pour l'erreur des scroll, bien que j'aime pas tellement ça, j'ai mis un On Error Resume Next.
J'ai aussi ajouter 2 constantes dans l'Enum
WM_MOUSEGAUCHEDROIT = &H20E 'Roulette à gauche et droite
WM_MOUSEBUTTONSUPP = &H20B 'Boutons supplémentaires 4 et 5 de la souris
avec deux constantes pour wParam (pas dans l'Enum)
Public Const BUTTONSUPLEFT = &H20 'Valeur de wParam pour différencier les 2 boutons
Public Const BUTTONSUPRIGHT = &H40 'supplémentaires voir WM_MOUSEBUTTONSUPP
Y aurait-il un lien qui donne une explication sur toutes les constantes ?
Leurs utilités et fonctionnement. ?
En tout cas, c'est nickel, merci également à RendField pour la classe.
A+
11 août 2012 à 13:19
Parfait, enfin presque, il faudrait contrôler les valeurs renvoyées aux scroll, tombe très vite en erreur au déplacement de la molette.
Mais ça je pense que c'est à la portée de tous.
A part ça tu est trop modeste, c’est valable pour tout contrôles ayant un hwnd, y compris la forme.
Egalement utile pour détecter tout les boutons de la souris.
Bravo et merci.
A+
PS: pas encore tester en compiler.
2 juin 2012 à 22:16
Tous les commentaires avant 2011 concernent l'ancienne version.
27 juil. 2010 à 23:48
Private Function ISubclasser_WindowProc(ByVal hWnd As Long, ByVal uMsg As MessageConstants, ByVal wParam As Long, ByVal lParam As Long) As Long
If hWnd <> mtWin1.hWnd Then Exit Function
ISubclasser_WindowProc = CallOldProc(mtWin1, hWnd, uMsg, wParam, lParam)
If uMsg = WM_MOUSEWHEEL Then Form1.DataGrid1.Scroll 0, 3 * Sgn(-wParam)
End Function
14 févr. 2010 à 14:12
12 févr. 2010 à 11:17
Je définit une classe comme suit:
Class1
------
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 m_def_DefaultLines As Long = 3
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 Property Set Datagrid(Optional ByVal plParenthWnd As Long 0, Optional ByVal plLines As Long m_def_DefaultLines, ByRef poDataGrid As Datagrid)
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 Property
Public Property Get EnabledWheel() As Boolean
EnabledWheel = mbWheelEnabled
End Property
Public Property Let EnabledWheel(ByVal pbEnabledWheel As Boolean)
If mbWheelEnabled Then Call UnhookWindow
If pbEnabledWheel Then Call HookWindow
End Property
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
End If
mbWheelEnabled = False
End Sub
Private Sub Class_Terminate()
Set moDataGrid = Nothing
End Sub
Puis un module définit comme suit:
Module1
-------
Option Explicit
Private Const WM_MOUSEWHEEL As Long = &H20A
Public Const PRPNAME As String = "WheelPrc"
Public moDataGrid As Datagrid, mlLines As Long
Public 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:
Dans votre Form contenant le datadrid1 mettre le code suivant
Option Explicit
Private moCls As Class1
Private Sub Form_Activate()
moCls.EnabledWheel = True
' SetWheelStatus True
End Sub
Private Sub Form_Load()
Set moCls.Datagrid(Me.hWnd) = DataGrid1
' LoadDatagrid DataGrid1, Me.hWnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
moCls.EnabledWheel = False
' SetWheelStatus False
End Sub
Private Sub Form_Initialize()
Set moCls = New Class1
End Sub
Private Sub Form_Terminate()
Set moCls = Nothing
End Sub
Encore merci à tous, please retourner si optimisation possible.
voila, j'ai pas voulu ravir la vedette aux autres en publiant une new Source, celle a déjà beaucoup de coms, meme pour moi ca me sert à comprendre l'évolution.
EB si tu passes par là , me dire comment contourner les bugs.
A+
12 févr. 2010 à 10:40
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
12 sept. 2009 à 09:19
merci Philippe734
9 sept. 2009 à 13:46
c'est urgent
18 juin 2009 à 09:13
Dommage que je n'arrive pas à le faire marcher sur les 3 onglets d'un MSHFlexGrid.
Ca fonctionne uniquement sur le dernier onglet.
Merci !
5 juin 2009 à 15:24
Ajout de la fonctionnalité Wheel en 30 secondes sur un MSFlexGrid sous VB6 portable,
et ça fonctionne en version compilée.
Merci.
20 nov. 2007 à 10:05
26 sept. 2007 à 03:03
9 sept. 2007 à 18:18
call UnhookWindow
:)
7 sept. 2007 à 12:19
22 août 2007 à 23:43
En bon debutant que je suis j'essaye de suivre ce conseil suivant :
"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 "
Le desactivermolette apparement n'existe pas, comment proceder??
3 nov. 2006 à 13:17
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...
3 nov. 2006 à 10:43
3 août 2006 à 16:26
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
29 mai 2006 à 17:35
14 févr. 2006 à 17:03
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 !!
6 févr. 2006 à 17:34
Chez moi il a fonctionné du 1er coup. Je cherchais ce type de source pour une Msflexgrid et ça marche !!!
Encore mille fois merci
26 janv. 2006 à 11:32
Call ActiverMoletteEtDéfinirObjetScroll(frm.grid)
et celle la dans le lostFocus
Call DesactiverMolette
Pour éviter tout problème
26 janv. 2006 à 11:29
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
25 janv. 2006 à 11:52
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?
18 oct. 2005 à 15:52
J'ai par contre un petit problème avec lors du transfert de mon projet de mon fixe a mon portable (tout deux sous XP). Alors que tout fonctionne nickel sur le fixe, lorsque je lance le projet en execution sur le portable il m'annonce "projet ou bibliotheque introuvable".
J'ai pourtant bien declaré wheel.tb dans les references du projet (redeclaré apres copie).
Merci d'avance des reponses.
18 oct. 2005 à 15:44
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?
18 oct. 2005 à 15:41
J'ai un petit problème que je ne comprends pas. J'ai developpé mon appli sur un fixe sur lequel la molette de la souris est tres bien prise en compte.
Je reprends aujourd'hui mon appli sur un portable, apres copie du projet (dans son ensemble) sur le portable, lorsque jele lance, il me dit bibliotheque introuvable (pour la fonction RegOpenKey). J'ai pourtant bien declaré le fichier wheel.tb dans les references. Merci d'avance de votre aide.
22 sept. 2005 à 15:31
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
22 sept. 2005 à 15:21
15 sept. 2005 à 19:47
Call ActiverMoletteEtDéfinirObjetScroll(Formulaire1.MSHFlexGrid1)
si "Formulaire1" est le nom de ma feuille.
29 août 2005 à 21:19
12 août 2005 à 21:20
petit souci, ne fonctionne pas en projet compilé. je suis le seul?
PCPT
8 août 2005 à 22:04
Prise en charge impossible.
Il s'agit d'un formulaire child qui roule dans une MDI...
Avez-vous trouvé une solution ? Ce code est simple d'usage et j'aimerais vraiment l'implanter dans mes logiciels.
24 mai 2005 à 23:59
merci
24 mai 2005 à 23:24
Merci.
19 avril 2005 à 19:45
:)
19 avril 2005 à 16:32
Mais avec les autres contrôles, çà va.
1 avril 2005 à 11:01
30 déc. 2004 à 12:35
j'ai un message d'error :
"prise en charge de la molette impossible"
c'est du à quoi ?
merci
8 déc. 2004 à 22:47
8 déc. 2004 à 17:49
comment faites vous pour charger l'api wheel.tlb? il me semble que j'ai un petit souci de chargement
merci pour votre aide!
29 sept. 2004 à 10:25
c tout ce kon lui demande..
5 août 2004 à 21:43
5 août 2004 à 21:30