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]

Re
jean marie

 

[patricktoulon]

@Phil69970
autrement dit tu a un trop grand écart
if faut réduire ECX et ECY pour pouvoir continuer et autoriser 150 chance de rattraper

soit un decalage de 15 points maxi (20 pixel)

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 UserForm2: Set .cel = cel: .Show modal: End With
End Function

Function placeOnRange(RNG As Range)
    Dim h2&, H1&, PtPx#, EcX&, Ecy&
    With ActiveWindow.ActivePane
    PtPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72 'coeff pixel
       If Not RNG Is Nothing Then x = .PointsToScreenPixelsX(RNG.Left): y = .PointsToScreenPixelsY(RNG.Top)
     
    End With
    EcX = Me.Width - 50   'ecart maximum toléré par la fonction en pixel
    Ecy = Me.Height - 50 'ecart maximum toléré par la fonction en pixel
    H1 = WindowXYFromPoint(x, y)
    With Me
        .StartUpPosition = 0
        .Left = (x / PtPx * ActiveWindow.Zoom / 100) + 15       ' je deregle la position exemple je le met à -100 de left
        .Top = (y / PtPx * ActiveWindow.Zoom / 100) + 15      ' je deregle la position exemple je le met à +10 de top
       
    End With
 
    'correction Left
    h2 = WindowXYFromPoint(x, y + Ecy)
    If h2 <> H1 Then
        Do While h2 <> H1 And b < 150: Me.Left = Me.Left + 0.1: h2 = WindowXYFromPoint(x, y + Ecy): b = b + 1: Loop: Me.Left = Me.Left - 1
    Else
        b = 0
        Do While h2 = H1 And b < 150: Me.Left = Me.Left - 0.1: h2 = WindowXYFromPoint(x, y + Ecy): b = b + 1: Loop: Me.Left = Me.Left - 1
    End If
 'correction top
    h2 = WindowXYFromPoint(x + EcX, y)
    If h2 <> H1 Then
        b = 0
       Do While h2 <> H1 And b < 150: Me.Top = Me.Top + 0.1: h2 = WindowXYFromPoint(x + EcX, y): b = b + 1: Loop: Me.Top = Me.Top - 1
    Else
         b = 0
      Do While h2 = H1 And b < 150: Me.Top = Me.Top - 0.1: h2 = WindowXYFromPoint(x + EcX, y): b = b + 1: Loop: Me.Top = Me.Top - 1  'on le repousse donc en bas
    End If
End Function
'////////////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////

Private Sub UserForm_Activate()
   
    If cel Is Nothing Then Set cel = [D5]
         placeOnRange cel
    End Sub

jean-marie toi il semble que + ou moins ça ne change pas donc je pense que l'ombre fait partie de la caption elle est compté dedans a l'inverse de chez moi par exemple

 

[Phil69970]

Re

Avec le code du post 182

@Phil69970

 

[patricktoulon]

re
Bonjour à tous

@Phil69970 bon ben voilà on est nikel
il fallait juste réduire la marge de ligne et colonne de départ
merci Phil69970
donc W7 excel 2013 ok
W10 excel 2010 ok
chez moi W10 excel 2016 64 bits ok

ps j'ai augmenté les marges d'erreur de positionnement a la base pour @ChTi160 qui parait avoir un peu plus
on a donc la possibilité de corrigé jusqu'à 100 de plus ou de moins pour le left et top
un message a la fin vous dit explicitement combien de décalage vous aviez

ça serait bien que @Dudu2 revienne pour tester sur ces deux system

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 UserForm2: Set .cel = cel: .Show modal: End With
End Function

Function placeOnRange(RNG As Range)
    Dim h2&, H1&, PtPx#, EcX&, Ecy&, BL#, BH#, q1$, q2$
    With ActiveWindow.ActivePane
    PtPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72 'coeff pixel
       If Not RNG Is Nothing Then x = .PointsToScreenPixelsX(RNG.Left): y = .PointsToScreenPixelsY(RNG.Top)
  
    End With
    EcX = Me.Width - 50
    Ecy = Me.Height - 50
   H1 = WindowXYFromPoint(x - 50, y - 50)
      With Me
        .StartUpPosition = 0
        .Left = (x / PtPx * ActiveWindow.Zoom / 100) ' + 50      ' je deregle la position exemple je le met à +50 de left
        .Top = (y / PtPx * ActiveWindow.Zoom / 100) ' - 50    ' je deregle la position exemple je le met à -50 de top
    
    End With
 
    'correction Left
 
   h2 = WindowXYFromPoint(x, y + Ecy)
   If h2 <> H1 Then
        q1 = "-"
        Do While h2 <> H1 And BL < 1000: Me.Left = Me.Left + 0.1: h2 = WindowXYFromPoint(x, y + Ecy): BL = BL + 1: Loop: Me.Left = Me.Left - 0.1
    Else
        q1 = "+"
        BL = 0
        Do While h2 = H1 And BL < 1000: Me.Left = Me.Left - 0.1: h2 = WindowXYFromPoint(x, y + Ecy): BL = BL + 1: Loop: Me.Left = Me.Left - 0.1
    End If
 
 'correction top
    h2 = WindowXYFromPoint(x + EcX, y)
    If h2 <> H1 Then
        BH = 0
       q2 = "-"
       Do While h2 <> H1 And BH < 1000: Me.Top = Me.Top + 0.1: h2 = WindowXYFromPoint(x + EcX, y): BH = BH + 1: Loop: Me.Top = Me.Top - 0.1
    Else
         BH = 0
      q2 = "+"
      Do While h2 = H1 And BH < 1000: Me.Top = Me.Top - 0.1: h2 = WindowXYFromPoint(x + EcX, y): BH = BH + 1: Loop: Me.Top = Me.Top - 0.1  'on le repousse donc en bas
    End If
 MsgBox "il y avait  " & q1 & BL / 10 & " de decalage left et " & q2 & BH / 10 & " de décalage top "
 End Function
'////////////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////

Private Sub UserForm_Activate()
 
    If cel Is Nothing Then Set cel = [D5]
         placeOnRange cel
    End Sub

reste plus qu'a intégrer ça dans mon model multipane

 

[Usine à gaz]

Bonjour Patrick, Le forum,
Positionnements chez moi Office 365 :
C3 :

D5 :

@plus,
lionel

 

[patricktoulon]

Bonjour @Usine à gaz
bon ben 365 vous vous en passerez car là je vois pas
si les handles ne sont pas captés ou que pointstoscreenpixels ne fonctionne pas chez vous ,je ne peux plus rien faire
j'ai testé chez moi 2013 et 2016
avec le userform
plus haut et plus a droite
plus haut et plus a gauche
plus bas et plus a droite
plus bas et plus a gauche
le userform revient toujours a sa place
peut être que c'est un truc qui a été supprimé sur 365
ça serait logique la gestion de fenêtre n’étant pas la même il est normale que pointstoscreenpixels soit disabled aussi
ou alors il faut faire sauter les activepane du code

donne moi simplement une cature avec ça dans un userform

Private Sub UserForm_Activate()
    With ActiveWindow.ActivePane
        PtPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72    'coeff pixel
        z = ActiveWindow.Zoom / 100
        l = (.PointsToScreenPixelsX([c3].Left) / PtPx) * z
        t = (.PointsToScreenPixelsY([c3].Top) / PtPx) * z
    End With
    Me.Move l, t
End Sub

essaie avec ".activepane" et sans
si ca marche pas c'est que vous n'avez plus cette fonction dispo sur votre version

 

[ChTi160]

Bonjour Patrick,
Mdr
Bonne journée
Jean marie

 

[patricktoulon]

Bonjour jean-marie
ouais mdr
ça fonctionne chez toi ? le #184

 

[Phil69970]

Re

Pas bon avec le post 184
Pour C3

Pour D5

Cela vient d'ici

Do While h2 <> H1 And BL < 1000: Me.Left = Me.Left + 0.1: h2 = WindowXYFromPoint(x, y + Ecy): BL = BL + 1: Loop: Me.Left = Me.Left - 0.1

Tu es passé de 150 au post 182 à ..... 1000 post 184 et .... patatras

@Phil69970

 

[patricktoulon]

re
@Phil69970 oui mais ça devrait rien changer normalement
les boucle doivent s'arréter car si
Do While h2 <> H1 And BH < 1000:
la condition c'est tant que condition1 ET!!!! condition2
si l'un ou l autre change la boucle doit s’arrêter
c'est pas logique que ça ne le face pas

 

[Phil69970]

Re

Il doit y avoir autre chose dans le code qui change entre le 182 et le 184 mais c'est pas trop de ma compétence.....
Juste pour info sur le code 184 si je mets 0.01 à la place de 1000 j'obtiens cela pour C3 et D5

@Phil69970

 

[Usine à gaz]

Bonjour @Usine à gaz
bon ben 365 vous vous en passerez car là je vois pas
si les handles ne sont pas captés ou que pointstoscreenpixels ne fonctionne pas chez vous ,je ne peux plus rien faire
j'ai testé chez moi 2013 et 2016
avec le userform
plus haut et plus a droite
plus haut et plus a gauche
plus bas et plus a droite
plus bas et plus a gauche
le userform revient toujours a sa place
peut être que c'est un truc qui a été supprimé sur 365
ça serait logique la gestion de fenêtre n’étant pas la même il est normale que pointstoscreenpixels soit disabled aussi
ou alors il faut faire sauter les activepane du code

donne moi simplement une cature avec ça dans un userform

Private Sub UserForm_Activate()
    With ActiveWindow.ActivePane
        PtPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72    'coeff pixel
        z = ActiveWindow.Zoom / 100
        l = (.PointsToScreenPixelsX([c3].Left) / PtPx) * z
        t = (.PointsToScreenPixelsY([c3].Top) / PtPx) * z
    End With
    Me.Move l, t
End Sub

essaie avec ".activepane" et sans
si ca marche pas c'est que vous n'avez plus cette fonction dispo sur votre version

LOL office365, c'est l'avenir = juste pour te motiver

 

[patricktoulon]

@Phil69970
et oui bien sur en fait il décale sans prendre en compte les conditions donc même avant c’était pas bon
c'est les conditions qui priment sur la décision de le déplacer
je pige vraiment pas pourquoi vos handles fenêtre ne sont pas captées

 

[patricktoulon]

j'ai changé le repere h1
et bloqué le reste
que dit le message chez vous

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 UserForm2: Set .cel = cel: .Show modal: End With
End Function

Function placeOnRange(RNG As Range)
    Dim h2&, H1&, PtPx#, EcX&, Ecy&, BL#, BH#, q1$, q2$, Lh&
    With ActiveWindow.ActivePane
    PtPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72 'coeff pixel
       If Not RNG Is Nothing Then x = .PointsToScreenPixelsX(RNG.Left): y = .PointsToScreenPixelsY(RNG.Top)
      Lh = .PointsToScreenPixelsX([A1].Left + 10)
    End With
    EcX = Me.Width - 50
    Ecy = Me.Height - 50
   H1 = WindowXYFromPoint(Lh, y - 50)
      With Me
        .StartUpPosition = 0
        .Left = (x / PtPx * ActiveWindow.Zoom / 100) ' + 50      ' je deregle la position exemple je le met à +50 de left
        .Top = (y / PtPx * ActiveWindow.Zoom / 100) ' - 50    ' je deregle la position exemple je le met à -50 de top
      
    End With
 
    'correction Left
  
   h2 = WindowXYFromPoint(x, y + Ecy)
 
  MsgBox H1 & vbCrLf & h2
   Exit function
   If h2 <> H1 Then
        q1 = "-"
        Do While h2 <> H1 And BL < 1000: Me.Left = Me.Left + 0.1: h2 = WindowXYFromPoint(x, y + Ecy): BL = BL + 1: Loop: Me.Left = Me.Left - 0.1
    Else
        q1 = "+"
        BL = 0
        Do While h2 = H1 And BL < 1000: Me.Left = Me.Left - 0.1: h2 = WindowXYFromPoint(x, y + Ecy): BL = BL + 1: Loop: Me.Left = Me.Left - 0.1
    End If
 
 'correction top
    h2 = WindowXYFromPoint(x + EcX, y)
    If h2 <> H1 Then
        BH = 0
       q2 = "-"
       Do While h2 <> H1 And BH < 1000: Me.Top = Me.Top + 0.1: h2 = WindowXYFromPoint(x + EcX, y): BH = BH + 1: Loop: Me.Top = Me.Top - 0.1
    Else
         BH = 0
      q2 = "+"
      Do While h2 = H1 And BH < 1000: Me.Top = Me.Top - 0.1: h2 = WindowXYFromPoint(x + EcX, y): BH = BH + 1: Loop: Me.Top = Me.Top - 0.1  'on le repousse donc en bas
    End If
 MsgBox "il y avait  " & q1 & BL / 10 & " de decalage left et " & q2 & BH / 10 & " de decalage top "
 End Function
'////////////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////

Private Sub UserForm_Activate()
  
    If cel Is Nothing Then Set cel = [D5]
         placeOnRange cel
    End Sub

ayant arreté le moulin on vois bien chez moi la différence d’identifiant de fenêtre app et userform

 

[Usine à gaz]

Chez moi :