Autres toutes versions tester le scrool avec la roulette sans passer par un hooking en addressof

[patricktoulon]

Bonjour a tous
la principal raison des crash excel quand on utilise le hooking de la souris pour avoir le mouse wheel(la roulette)
c'est que le looping avec le (CallnextHook)est asynchrone avec le captage du message de la souris
donc quand une erreur se produit(on va trop vite ou autre)
le looping lui continue parfois au moins une fois même en erreur
résultat comme on déplace le block type du message en mémoire ça crash

je vous propose de tester ceci
ici on va rester dans un do/loop vba classique et le message de la souris sera récupéré par un peekmessage
si il y a une erreur (du au message de la souris non conforme) normalement on a une erreur vba classique
et donc le do/loop est interrompu
donc pas de relance avec un message de la souris erroné donc pas de crash
Vous constaterez que j'augmente l'allocation de la mémoire aussi (64 bits double (longlong ou longPtr))(+2&)

d'autant plus que la dans cette démo je met tout dans le userform
ce qui n'est pas possible avec un code de hooking bien entendu
et ça peut avoir un avantage lorsque l'on veut distribuer un interface(userform) sans devoir l'accompagner de x modules

toujours pareil pour déterminer le rectangle je me sert de ma fonction perso du calendar que j'ai modifié pour ce besoins
donc testez et si ça fonctionne je ferais une ressource au propre

merci d'avance pour votre participation

j'en connais un qui vas ouvrir grand les yeux 🤣

Patrick

 

[Valtrase]

Bonjour à tous,
Bon pour ma part sous Windows 10 double écrans, 1920X1080 zoom 100% Avec Excel 32Bits tout à l'air OK.👌
Je testerais ce soir sur la configuration portable 64Bits...

 

[jurassic pork]

le ppx vous donne bien le coeff
0.75 pour 100%
0.6... pour 125
????

bon ça donne 0.6 pour le 100% et le 125%

 

[Dudu2]

le ppx vous donne bien le coeff
0.75 pour 100%
0.6... pour 125
????

Non, avec ça:

     Function PointToPixel() As Double
        'Static SavePointToPixel As Double
        Dim SavePointToPixel As Double
     
        If SavePointToPixel = 0 Then
            SavePointToPixel = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1)
        End If
        PointToPixel = SavePointToPixel
    End Function

J'obtiens toujours 0.6 en partant de 125% et en allant sur 100%
Je me demande si le registre n'est pas mis à jour seulement au démarrage.

 

[jurassic pork]

J'obtiens toujours 0.6 en partant de 125% et en allant sur 100%
Je me demande si le registre n'est pas mis à jour seulement au démarrage.

c'est vrai que je change la mise à l'échelle sans me déloguer et j'étais à 125% quand je me suis logué

 

[patricktoulon]

re merci valtraze


je viens de faire le test en 125%
mis a part que ca me zoom les control (un truc a devenir fou) 🤣 🤣 🤣
chez moi le looping reste à l'inverse de chez @jurassic pork

par contre quand je suis revenu a 100% les controls ont été déformés et replacés
j'ai fermé et ré ouvert le fichier et j'ai replacé mes controls et c'est bon
donc vos problèmes c'est que vous avez switché le zoom windows au moins une fois depuis le démarrage du pc et ca perturbe les affichage
dans excel

 

[Rheeem]

quelqu'un peu me donner un exemple de l'utilisation de accLocation
pour voir si je peut pas determiner le rectangle avant avec iaccessible

regarder cet exemple

Dim acc As IAccessible
Dim l As Long, t As Long, w As Long, h As Long
Set acc = TextBox1
acc.accLocation l, t, w, h, 0&

MsgBox l & "  " & t & " " & w & " " & h

 

[patricktoulon]

il y a donc un sérieux problème avec ces controls sur feuille par rapport a window
après moi je n'ai pas de problème car comme je l'ai déjà dit a @Dudu2 plusieurs fois mon affichage est géré a 100% par le panneau config d'affichage de NVIDIA et pas celui de window et j'ai donc un coeff de 0.75 que je soit a 100 ou 125%

 

[jurassic pork]

regarder cet exemple

Dim acc As IAccessible
Dim l As Long, t As Long, w As Long, h As Long
Set acc = TextBox1
acc.accLocation l, t, w, h, 0&

MsgBox l & "  " & t & " " & w & " " & h

Attention le accLocation n'est pas toujours disponible et pour une ListBox cela me renvoyait 0 0 0 0

 

[patricktoulon]

regarder cet exemple

Dim acc As IAccessible
Dim l As Long, t As Long, w As Long, h As Long
Set acc = TextBox1
acc.accLocation l, t, w, h, 0&

MsgBox l & "  " & t & " " & w & " " & h

d’accords rheem c'est donc 4 variable et non un rect
je cherchais avec une variable type moi 🤣 🤣 🤣 🤣 🤣 🤣
faut dire ms ne t'aide pas

 

[patricktoulon]

Attention le accLocation n'est pas toujours disponible et pour une ListBox cela me renvoyait 0 0 0 0

je vais tester

 

[patricktoulon]

@jurassic pork
en effet ca renvoie 0,0,0,0
mince piste avorté

 

[jurassic pork]

Pour le souci de changement de mise à l'échelle voici ce que Léo m'a répondu :

Inexactitude WindowMetrics AppliedDPI​

La valeur de WindowMetrics\AppliedDPI dans le registre peut ne pas refléter avec précision les paramètres de mise à l'échelle DPI actuels sur Windows 11, car il ne se met pas à jour immédiatement lorsque le facteur de mise à l'échelle est modifié par les paramètres du système d'exploitation.45 Cela peut entraîner des divergences lorsque la valeur du registre reste au paramètre DPI précédent, même après que l'utilisateur a ajusté la mise à l'échelle dans les paramètres du système.5

Pour déterminer avec précision l'échelle DPI pour chaque moniteur, vous pouvez utiliser GetDpiForMonitor fonction de la Shcore.dll bibliothèque, qui fournit les valeurs DPI correctes pour les paramètres d'affichage actuels.5 Cette méthode est plus fiable pour les applications qui doivent ajuster leur mise en page en fonction des paramètres DPI de l'affichage de l'utilisateur.

 

[patricktoulon]

et oui mais elle ne fonctionne pas sur 2007 cet api souvient toi
sinon oui essaie avec cet api
sinon dernier recours par le activewindow c'est pris dans l'instanté

Function PpX()
   Dim z#
   With ActiveWindow.Panes(1)
        z = .Parent.Zoom / 100
        PpX = 1 / ((.PointsToScreenPixelsX(72 / z) - .PointsToScreenPixelsX(0)) / 72)
    End With
End Function

 

[Dudu2]

C'est pour ça que je suis revenu au Pixel / Point de base.
Je sais, c'est long et quand on veut zipper le code ça ne fait pas bon effet.
Mais je n'ai rien trouvé de mieux qui soit générique.

Et encore, en multi-moniteurs je ne sais pas trouver le ratio pour un moniteur donné, en supposant que les moniteurs peuvent avoir des ratios différents.

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If

Private Const LOGPIXELSX = 88  'Pixels/inch in X
Private Const LOGPIXELSY = 90  'Pixels/inch in Y

'--------------------
'Point to Pixel ratio
'--------------------
Private Function PointToPixel() As Double
    Dim DotsPerInch As Double
    Dim hDC As Variant
  
    hDC = GetDC(0)
    DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    Call ReleaseDC(0, hDC)
    PointToPixel = DotsPerInch / Application.InchesToPoints(1)
End Function

 

[patricktoulon]

re
j'ai changé la fonction pixel et remis le releasecontrol comme dans la version IAccessible pour relacher la combo
ca en fait des version elle fonctionnes toutes chez moi
mais certaines n'ont pas certaines options mais le moteur a proprement parler sont tous fonctionnels
cette version 4 a mon avis est une alternative pour ce qui sont ennuyés avec iaccessible et autres joyeusetés
@jurassic pork tu me diras sur ton 2013