Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Créer une discussion

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire

patricktoulon

XLDnaute Barbatruc
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
 

Pièces jointes

Dernière édition:
Trier par date Trier par votes
@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)
VB: 
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
 
Dernière édition:
Vote positif 0 Vote négatif
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 😉
VB: 
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😂
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
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
VB: 
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
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
LOL office365, c'est l'avenir = juste pour te motiver 😛🤣
 
Vote positif 0 Vote négatif
j'ai changé le repere h1
et bloqué le reste
que dit le message chez vous
VB: 
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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…