Autres toutes version excel tester le calendar en mode modal et non modal sur range ou control dans userform

[patricktoulon]

Bonjour a tous
j'ai pris le temps ce matin de voir un peu ce que je pourrais faire pour mon calendar
en effet il m'est souvent venu des demandes quand au fait que quand l'object appelant et fils d'un userform non modal
et effectivement mon calendar qui est en mode responsif(MODAL)(se comporte comme un msgbox) n'est pas compatible forcement
le conflit d'affichage d'un usf modal par dessus un usf non modal est déclenché
j'ai donc ici recommencé tout a zero (c'est une ébauche)mais il est parfaitement fonctionnel
dites moi ce que vous en pensez
on verra après pour les couleurs et les fériés les langue et region et tout le tointoin
merci pour les retours et suggestion a venir

 

[ChTi160]

Bonsoir
Chez moi !
W11 o365 même résultat que Dudu2 #148
Merci
jean marie

 

[Phil69970]

Bonjour à vous tous

Pour W10 64 bits et excel 2010 64 bits

windows version 6,02
excel version =14
decalage gauche= 4
decalage top= 4

@Phil69970

 

[patricktoulon]

re

bonsoir @Phil69970
c'est ce que renvoie

Op = Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ")))
    appv = Val(Application.Version)

qu'il me faut

 

[Phil69970]

Re

Patrick

c'est ce que renvoie
VB:

Op = Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ")))
appv = Val(Application.Version)

qu'il me faut

J'avais bien compris et ça me renvoie dans Debug.Print "windows version " & op
==> windows version 6,02

C'est bien pourquoi je t'ai mis ma version de Windows et d'excel

@Phil69970

 

[patricktoulon]

re
normalement celui là est universel
j'étais pas loin avec le windowfrompoint
je l'ai testé avec en moins en plus et vis et versa ça colle

#If VBA7 Then
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xpoint As Long, ByVal ypoint As Long) As Long
#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xpoint As Long, ByVal ypoint As Long) As Long
#End If

Sub test2222()
    hwndA = Application.hwnd
    x = ActiveWindow.ActivePane.PointsToScreenPixelsX([C3].Left)
    y = ActiveWindow.ActivePane.PointsToScreenPixelsY([C3].Top)
    h1 = WindowFromPoint(x, y)    'on capte le handle de la fenetre qui ce trouve a ce point  precis!!!!!
    With UserForm1
        .StartUpPosition = 0
        .Left = (x / PtoPX * ActiveWindow.Zoom / 100)
        .Top = (y / PtoPX * ActiveWindow.Zoom / 100)
        .Show 0
    End With

    'correction left
    h2 = WindowFromPoint(x, y + 20)    'on prend un point sur X de left  <<<<un peu plus bas de 20 pixel>>>>
    If h2 <> h1 Then    'si les deux handle sont différent(ca veux dire qu'il est décaler a droite)
        'on le rammene a gauche tant que h1 et h2 sont différents
        Do While h2 <> h1: UserForm1.Left = UserForm1.Left + 0.1: h2 = WindowFromPoint(x, y + 20): Loop
    Else    'sinon ca veut dire qu'il mange un peu le left
        Do While h2 = h1: UserForm1.Left = UserForm1.Left - 0.1: h2 = WindowFromPoint(x, y + 20): Loop    'on le repousse donc a droite
    End If

    'correction top(ben on fait pareil symetriquement parlant
    h2 = WindowFromPoint(x + 20, y)    'on prend un point <<<un peu plus a droitede 20 pixel>>>>  mais sur Y pilpoil
    If h2 <> h1 Then    'si les deux handle sont différent(ca veux dire qu'il est décaler en bas )
        'on le rammene en top Y tant que h1 et h2 sont différents
        Do While h2 <> h1: UserForm1.Top = UserForm1.Top + 0.1: h2 = WindowFromPoint(x + 20, y): Loop
    Else    'sinon ca veut dire qu'il mange un peu le top
        Do While h2 = h1: UserForm1.Left = UserForm1.Left - 0.1: h2 = WindowFromPoint(x + 20, y): Loop    'on le repousse donc en bas
    End If
End Sub
Public Function PtoPX()
    With ActiveWindow.ActivePane
        PtoPX = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72    'coeff
    End With
End Function

 

[ChTi160]

Bonjour Patrick
Bonjour le Fil
tu fais quoi avec ce code
tu le mets ou ?
j'ai créer un fichier mis un Userform1
ajouté un Module!
mis le Code et lancé la procédure "test2222"
et bien pas Bon ! j'ai du faire une erreur !Lol (ctrl+Alt+Supp) obligé Lol
peux tu m'expliquer ?
Merci
Bonne journée
Edit : autre question
J'ai dans tout les Fichier qui on cette Ligne une erreur !
Comment y remédier autrement qu'en y mettant "PrtSafe"
Jean marie

 

[patricktoulon]

Bonjour ChTi160
je l'ai légèrement corrigé
j'ai ajouté la possibilité d'une marge d'erreur a corrigé de pratiquement la largeur et hauteur de la fenêtre
pour ptrsafe en effet j'ai donc mis l'api en macro 4 compatible toute versions

voilà
tu met ce code dans un module et tu ajoute un userform a ton projet
et lance la sub
j'ai testé en décalant de +100 et -100 le left et top dans tout les sens le userform revient toujours en C3

l'erreur que je faisait hier et de croire que je pouvais redresser les marge left et top en meme temps
en fait il faut le faire séparément comme ça ,cela peut être - pour left et + pour top et vise et versa ou ++ ou --

Sub testX()
    UserForm1.ShowOnCell [c3], 0
End Sub

et ça dans le userform

Public cel As Range
Public Function WindowXYFromPoint(x, y): WindowXYFromPoint = ExecuteExcel4Macro("CALL(""user32"",""WindowFromPoint"",""JJJ""," & x & ", " & y & ")"): End Function
Public Function ShowOnCell(cel As Range, Optional modal As Boolean = vbModal)
    With UserForm1: Set .cel = cel: .Show modal: End With
End Function

Function correction()
    Dim x#, y#, h2&, h1&, PtPx#, EcX&, EcY&
    With ActiveWindow.ActivePane
        x = .PointsToScreenPixelsX(cel.Left): y = .PointsToScreenPixelsY(cel.Top)
        PtPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72    'coeff
    End With
    EcX = Round(Me.Width - Me.InsideWidth) * PtPx    'ecart maximum toléré par la fonction en pixel
    EcY = Round(Me.Height - Me.InsideHeight) * PtPx    'ecart maximum toléré par la fonction en pixel

    h1 = WindowXYFromPoint(x, y)
    With Me
        .StartUpPosition = 0
        .Left = (x / PtPx * ActiveWindow.Zoom / 100) - 100    ' je deregle la position exemple je le met à -100 de left
        .Top = (y / PtPx * ActiveWindow.Zoom / 100) + 100   ' je deregle la position exemple je le met à +10 de top
        .Show 0
    End With
    'correction top
    h2 = WindowXYFromPoint(x + EcX, y)
    If h2 <> h1 Then
        Do While h2 <> h1: Me.Top = Me.Top + 0.1: h2 = WindowXYFromPoint(x + EcX, y): Loop
    Else
        Do While h2 = h1: Me.Top = Me.Top - 0.1: h2 = WindowXYFromPoint(x + EcX, y): Loop    'on le repousse donc en bas
    End If

    'correction Left
    h2 = WindowXYFromPoint(x, y + EcY)
    If h2 <> h1 Then
        Do While h2 <> h1: Me.Left = Me.Left + 0.1: h2 = WindowXYFromPoint(x, y + EcY): Loop
    Else
        Do While h2 = h1: Me.Left = Me.Left - 0.1: h2 = WindowXYFromPoint(x, y + EcY): Loop
    End If
End Function
'////////////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////

Private Sub UserForm_Activate()
    If Not cel Is Nothing Then correction
End Sub

+100 ou -100 on est vraiment dans l'extreme là pour l'erreur

 

[patricktoulon]

tiens test ce fichier
lance la sub
et je viens de tester ca marche même sans thème aéro ou roamed pour W10

 

[ChTi160]

Bonjour Patrick
Merci je teste des que possible .
Bonne journée
Jean marie

 

[Eric C]

Bonjour le fil, le forum

Testé sous Win10 - XL 2010 32 bits

 

[ChTi160]

Re
Chez moi W11 o365 32
jean marie

 

[patricktoulon]

merci @Eric C c'est correct je sais comment faire pour le tout petit decalage gauche
c'est un problème d'arrondi VBA

@ChTi160 essai sans la fenêtre vba affiché il est possible qu'il y est confusion du handle de départ

essayez celui là

 

[patricktoulon]

en attendant voici des news du skinner du calendar
il a encore évolué je peux conserver les skin comme avant maintenant
et les réutiliser ou les modifier

 

[ChTi160]

Re je ne pense pas j'ai testé sans !
Je re test ce soir !
Merci
Jean marie

 

[Phil69970]

Re

Patrick
Chez moi ton fichier du post 162 cela fige excel

L'USF se décale vers la gauche tout doucement et disparait et excel se fige (tester avec les 2 boutons C3 et D5)

@Phil69970