Autres Petite mise a jour (exceptionnellement pour cp4) du calendar V4.1(OLDVERSION)

[patricktoulon]

Bonjour @cp4
pour faire suite à ton message en MP ,concernant une vielle version du calendar la V4.1

je tiens tout d'abords a dire qu'il y a eu plus de 20 versions au moins qui ont suivi cette version celle ci datant d'à peu près 2019

j'ai donc dézippé mes archives et tu a de la chance j'ai retrouvé la version 4.1.1( c'est la plus ancienne que j'ai gardé dans le zip)
et encore tu a vraiment de la chance je me demande bien pourquoi je l'ai gardé

comme je t'ai dit il n'y a pas de principe double input pour le calendar
mais tu peux très bien jouer cela avec l'event de la cellule dans une feuille
et faire une toute petite modif dans le calendar

j'en ai profité pour revoir le placement sur cellule cette fonction était une vrai usine à gaz inutile

autrement dit ici par exemple en l’occurrence j'ai deux cellules date ( départ/arrivée) ce sont les cellule C3 et C6
en cliquant droite sur C3 le calendar doit s'ouvrir
une fois la date choisi ca passe tout seul a la C6 et le mois et année sont celle de C3

tel que je le code dans l'event beforerightclick rien ne t’empêche de re modifier la C6

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'exemple départ en C3 et arrivée en C6
    Select Case Target.Address(0, 0)
    Case "C3"
        oldvalue = [c3]
        Cancel = True
        Target.Value = Calendar.ShowX(Target, 2, 0, 1)
        If Target = oldvalue Then Exit Sub
        [c6] = [c3]
        [c6].Value = Calendar.ShowX([c6], 2, 0, 1)
        If [c6] = [c3] Then [c6] = ""
    Case "C6"
        Cancel = True
        Target.Value = Calendar.ShowX(Target, 2, 0, 1)
    Case Else: Cancel = False
    End Select
End Sub

encore une fois ça démontre bien que même les oldversions du calendar sont adaptables à diverses demandes
sans toucher le moindre code du calendar

à l'avenir pour une question d'adaptation perso fait une demande sur le forum
Merci de ta compréhension

ps: il va de soit que le même principe est applicable pour des textbox dans un userform

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        TextBox1 = Calendar.ShowX(TextBox1, 2, 0, 1)
        TextBox2 = TextBox1
        TextBox2 = Calendar.ShowX(TextBox2, 2, 0, 1)
    If TextBox2 = TextBox1 Then TextBox2 = ""
    End If
End Sub

Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
            TextBox2 = Calendar.ShowX(TextBox2, 2, 0, 1)
     End If
End Sub

voila

 

[Nico_J]

Salut Patrick,
On relance le sujet ??
non hein

@+

 

[patricktoulon]

re
bonsoir @Nico_J
je pige pas très bien ton intervention?

 

[Nico_J]

Tu te rapelles:

Function PositionForm(FORM As Object, rng As Range)
Dim Z As Double, K As Double
 
Z = ActiveWindow.Zoom / 100
K = ((ActiveWindow.ActivePane.PointsToScreenPixelsX(ActiveSheet.[A1].Width) - ActiveWindow.ActivePane.PointsToScreenPixelsX(0)) / ActiveSheet.[A1].Width) / Z
 
lleft = ActiveWindow.PointsToScreenPixelsX(rng.Left * K * Z) / K - 5
ttop = ActiveWindow.PointsToScreenPixelsY(rng.Top * K * Z) / K
PositionForm = Array(lleft, ttop)
 
End Function
 
Sub TestUserform()
    r = PositionForm(UserForm1, ActiveCell)
    With UserForm1: .Show 0: .Left = r(0): .Top = r(1): End With
End Sub

Le fameux décalage, il y est toujours

 

[Nico_J]

C'est pas moi qui va te donner des leçon, super boulot.

 

[Nico_J]

Comme ça, ça va bien pour moi,

Private Function placementRange(Obj As Object)
    If Obj Is Nothing Then Exit Function
    Dim Z#, L1#, T1#, Hx#, Wx#, PtoPx#
    With ActiveWindow
        PtoPx = 1 / ((.ActivePane.PointsToScreenPixelsX(7200) - .ActivePane.PointsToScreenPixelsX(0)) / 7200)  'coeff point to pixel
        Z = (.Zoom / 100)
        L1 = (.ActivePane.PointsToScreenPixelsX(Int(Obj.Left)) * PtoPx) * Z - 5    'placement partie mobile
        T1 = .ActivePane.PointsToScreenPixelsY(Int(Obj.top)) * PtoPx * Z
    
    End With
    'option de placement :
    Wx = (Obj.Width / 2) * Z * Px
    Hx = (Obj.Height / 2) * Z * Py
    L1 = L1 + (Wx)
    T1 = T1 + (Hx)
    With Me: .Left = L1: .top = T1: End With
End Function

le fameux -5 au left

 

[cp4]

Bonjour @cp4
pour faire suite à ton message en MP ,concernant une vielle version du calendar la V4.1

je tiens tout d'abords a dire qu'il y a eu plus de 20 versions au moins qui ont suivi cette version celle ci datant d'à peu près 2019

j'ai donc dézippé mes archives et tu a de la chance j'ai retrouvé la version 4.1.1( c'est la plus ancienne que j'ai gardé dans le zip)
et encore tu a vraiment de la chance je me demande bien pourquoi je l'ai gardé

comme je t'ai dit il n'y a pas de principe double input pour le calendar
mais tu peux très bien jouer cela avec l'event de la cellule dans une feuille
et faire une toute petite modif dans le calendar

j'en ai profité pour revoir le placement sur cellule cette fonction était une vrai usine à gaz inutile

autrement dit ici par exemple en l’occurrence j'ai deux cellules date ( départ/arrivée) ce sont les cellule C3 et C6
en cliquant droite sur C3 le calendar doit s'ouvrir
une fois la date choisi ca passe tout seul a la C6 et le mois et année sont celle de C3

tel que je le code dans l'event beforerightclick rien ne t’empêche de re modifier la C6

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'exemple départ en C3 et arrivée en C6
    Select Case Target.Address(0, 0)
    Case "C3"
        oldvalue = [c3]
        Cancel = True
        Target.Value = Calendar.ShowX(Target, 2, 0, 1)
        If Target = oldvalue Then Exit Sub
        [c6] = [c3]
        [c6].Value = Calendar.ShowX([c6], 2, 0, 1)
        If [c6] = [c3] Then [c6] = ""
    Case "C6"
        Cancel = True
        Target.Value = Calendar.ShowX(Target, 2, 0, 1)
    Case Else: Cancel = False
    End Select
End Sub

encore une fois ça démontre bien que même les oldversions du calendar sont adaptables à diverses demandes
sans toucher le moindre code du calendar

à l'avenir pour une question d'adaptation perso fait une demande sur le forum
Merci de ta compréhension

ps: il va de soit que le même principe est applicable pour des textbox dans un userform

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        TextBox1 = Calendar.ShowX(TextBox1, 2, 0, 1)
        TextBox2 = TextBox1
        TextBox2 = Calendar.ShowX(TextBox2, 2, 0, 1)
    If TextBox2 = TextBox1 Then TextBox2 = ""
    End If
End Sub

Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
            TextBox2 = Calendar.ShowX(TextBox2, 2, 0, 1)
     End If
End Sub

voila

Bonsoir @patricktoulon ,

Je me suis empressé de lire d’abord ton mp. Merci infiniment, je ne m'attendais à autant d'attention.
Tu me donnes la solution, je n'aurai donc pas à donner ma langue au chat.
Si problème, je reviendrai vers toi.
Toute ma gratitude.
Excellente soirée.

 

[patricktoulon]

re
@Nico_J
oui avec w10 c'est plus propre
c'est la méthode du calendar 5.0
le "-5" c'est arbitraire car ça peut être bon chez toi et chez un autre moins ou plus
seule l'api dwmapi.dll peut faire quelque chose de générique
mais comme je l'ai fait compatible MAC sur les versions 4.4 à 5.0
les apis on oublie

d'autre part je te le dis à toi aussi , comme a un autre membre têtu comme une mule
si tu a W10 ou 11
et tu tourne avec les drivers graphique génériques de Windows
téléchargé par les mises a jour Window
et ben c'est normal que ça soit moins précis

quand j'ai installé mes drivers et gestionnaire graphiques sur le site du distributeur de la carte graphique ,tout ces petits détails ont disparus

a bon entendeur

 

[patricktoulon]

de rien @cp4
je fait juste une allergie a la poussière qu'il y avait sur la V4.1.1

 

[Nico_J]

re
Désolé que tu me dises que je suis têtu, je n'est pas les drivers graphiques génériques, mes drivers sont chez NVIDIA pour ma RTX3070 à jour et W10 64bits

C'était juste pour t'informer.

 

[patricktoulon]

re
non!!!!!!!!!!!!!!!!!! quand tu a les bon
Windows te repropose tout le temps de les mettre à jour
il faut bloquer la ligne dans les mises ajour proposées de Windows pour qu'il ne te les changent plus
Windows ne reconnait que les WHQL
mais ceux signés par NVIDIA il les vires
et le pire c'est que ceux de windows ont le même numéro de version mais suivi de quelque chose
si tu fait pas gaffe au démarrage windows ta mis la version générique des drivers
et il y a plein de trucs du gestionnaire NVIDIA qui ne fonctionneront pas
saleté de W10 VA !!!

 

[Nico_J]

re
non!!!!!!!!!!!!!!!!!! quand tu a les bon
Windows te repropose tout le temps de les mettre à jour
il faut bloquer la ligne dans les mises ajour proposées de Windows pour qu'il ne te les changent plus
Windows ne reconnait que les WHQL
mais ceux signés par NVIDIA il les vires
et le pire c'est que ceux de windows ont le même numéro de version mais suivi de quelque chose
si tu fait pas gaffe au démarrage windows ta mis la version générique des drivers
et il y a plein de trucs du gestionnaire NVIDIA qui ne fonctionneront pas
saleté de W10 VA !!!

Je sais pas après, j'ai les notifications NVIDIA pour me dire qu'il y a une mise à jour dispo de la carte mais pas windows

 

[TooFatBoy]

Bonjour,

Juste pour info : perso je n'ai heureusement pas une CG nVidia, et pourtant j'ai aussi le décalage vers la droite, mais pas vers verticalement.

Je pensais que le décalage était voulu, tout comme le fait de l'afficher dans la cellule à côté de celle où on a cliquée au lieu de l'afficher logiquement à l'endroit cliqué.

 

[Nico_J]

Bonjour,

Perso je n'ai heureusement pas une CG nVidia, et pourtant j'ai aussi le décalage vers la droite, mais pas vers verticalement.

Je pensais que le décalage était voulu, tout comme le fait de cliquer dans une cellule et que ça s'affiche dans une autre cellule au lieu de s'afficher logiquement à l'endroit cliqué.

Bonjour,
remplacer la fonction proposé du même nom par celle si pour voir
merci

Private Function placementRange(Obj As Object)
    If Obj Is Nothing Then Exit Function
    Dim Z#, L1#, T1#, Hx#, Wx#, PtoPx#
    With ActiveWindow
        PtoPx = 1 / ((.ActivePane.PointsToScreenPixelsX(7200) - .ActivePane.PointsToScreenPixelsX(0)) / 7200)  'coeff point to pixel
        Z = (.Zoom / 100)
        L1 = (.ActivePane.PointsToScreenPixelsX(Int(Obj.Left)) * PtoPx) * Z - 5     'placement partie mobile
        T1 = .ActivePane.PointsToScreenPixelsY(Int(Obj.top)) * PtoPx * Z
        
    End With
    'option de placement :
    Wx = (Obj.Width / 2) * Z * Px
    Hx = (Obj.Height / 2) * Z * Py
    L1 = L1 '+ (Wx)
    T1 = T1 + (Hx)
    With Me: .Left = L1: .top = T1: End With
End Function

 

[TooFatBoy]

Avec cette fonction, il n'y a plus de décalage.