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

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

  • calendar light.xlsm
    34.4 KB · Affichages: 42
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
merci @Phil6970
c'est bizarre que h1 ne soit pas capté tu a le même résultat que @Cthi160
je vais modifier pour arrêter les boucles automatiquement ca réduit la capacité de redressement mais bon on aura un aperçu de ce qui se passe chez vous au moins
 

patricktoulon

XLDnaute Barbatruc
@Phil69970
ok bizarre elle est plus basse et plus a droite ça devrait coller
alors je crois que tu n'a pas de décalage
chez toi ceci doit aller pilpoil

dans un userform
VB:
Private Sub UserForm_Activate()
 Dim PtoPx#, z#, L#, t#, Cel As Range
    Set Cel = [C3]
     z = ActiveWindow.Zoom / 100
   With ActiveWindow.ActivePane
        PtoPx = (.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72
           L = (.PointsToScreenPixelsX(Cel.Left) / PtoPx) * z
     t = (.PointsToScreenPixelsY(Cel.Top) / PtoPx) * z
     End With
Me.Move L, t
End Sub
 

patricktoulon

XLDnaute Barbatruc
franchement j'y comprends plus rien c'est pas cohérent tout ça
un coup oui un coup non
bon pour le problème ce Phil69970 j'ai compris
h1 est pris apres le show et il y a déjà le userform donc la bascule h1<>h2 ne peut pas coller forcément
il faut que je trouve une autre bascule pour démarrer du handle (h1) en tant qu'excel
chez toi @ChTi160 c'est complètement incohérent alors je sais pas
 

patricktoulon

XLDnaute Barbatruc
re
tout le monde a la meme enseigne on demarre plus bas et plus a droite de 15 points de plus
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 = 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) + 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 < 100: 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 < 100: 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 < 100: 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 < 100: 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
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…