Majuscule en Gras et Rouge

Salut Mike
je viens de poster car encore un petit souci
mais essaie ca marche

Ce code est senser faire défiler le texte dans A1 pendant quelques secondes puis une tempo de 3 secondes et c'est le texte de la cellule A2 qui défile.

Et bien ca défile mais les majuscules qui sont en gras et rouge ne le sont plus. pourquoi sniff sniff

Raymond



Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Sub Tst()
Dim X, Z, O As Byte

[A1] = Application.Proper(Format(Date, "dddd dd mmmm yyyy "))
[A2] = "Semaine: " & DatePart("ww", Date, vbMonday) & " " & _
DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année" & " "

With [A1:A2].Characters(1).Font
.FontStyle = "gras"
.ColorIndex = 3
End With

With [A1:A2].Characters(2).Font
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

X = InStr(InStr([A1], " ") + 2, [A1], " ") 'Détecte 2 espaces dans la date
Z = InStr(InStr([A2], " ") + 12, [A2], " ") 'Détecte pour le J de jour

With [A1].Characters(X + 1).Font 'Pour deuxième majuscule Mois
.FontStyle = "Gras"
.ColorIndex = 3
End With

With [A2].Characters(Z + 1).Font 'Pour premier caractere jour en rouge
.FontStyle = "Gras"
.ColorIndex = 3
End With

With [A2].Characters(Z + 2).Font 'Pour apres premier caractere jour en noir
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

With [A1].Characters(X + 2).Font
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

'End 'Pour ne pas effectuer le défilement

'*** CODE POUR LE DEFILEMENT DES DEUX MESSAGES CELLULES A1/A2
[A1].Font.ColorIndex = 0
[A1].Font.Bold = False

Dim C As Range: Dim D As Range: Dim i
Set C = [A1]

For i = 1 To 40 'Durée de rotation de la date
C = Right(C, Len(C.Value) - 1) + Left(C, 1)
Sleep 150 'Vitesse de rotation
Next i

[A1] = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))

With [A1].Characters(1).Font
.FontStyle = "gras"
.ColorIndex = 3
End With

With [A1].Characters(2).Font
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

X = InStr(InStr([A1], " ") + 2, [A1], " ") 'Détecte 2 espaces dans la date

With [A1].Characters(X + 1).Font 'Pour deuxième majuscule Mois
.FontStyle = "Gras"
.ColorIndex = 3
End With

With [A1].Characters(X + 2).Font
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

Application.Wait (Now + TimeValue("00:00:03")) 'Tempo de 3 secondes

[A2].Font.ColorIndex = 0
[A2].Font.Bold = False
Set D = [A2]

For i = 1 To 40 'Durée de rotation semaine et jour
D = Right(D, Len(D.Value) - 1) + Left(D, 1)
Sleep 150 'Vitesse de rotation
Next i

[A2] = "Semaine: " & DatePart("ww", Date, vbMonday) & " " & _
DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année"

With [A2].Characters(1).Font
.FontStyle = "gras"
.ColorIndex = 3
End With

With [A2].Characters(2).Font
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With

With [A2].Characters(Z + 1).Font 'Pour premier caractere jour en rouge
.FontStyle = "Gras"
.ColorIndex = 3
End With

With [A2].Characters(Z + 2).Font 'Pour apres premier caractere jour en noir
.FontStyle = "Normal"
.ColorIndex = xlAutomatic
End With
End Sub

Demande à Raymond de t'expliquer son code, à défaut je m'y pencherai, c'est pas très compliqué, sans pour autant le modifier, ce ne serait pas bien

A+
Mike-31

Un problème sans solution est un problème mal posé  (Einstein)

Re Mike

Tu as raison je vais demander a Mr PMO2 s'il veut bien commenter son code afin d'en comprendre le déroulement.

Cependant j'ai agrandir la taille de la date en A1 donc j'ai mis 12 j'ai fait défiler ca saccade beaucoup
si tu as le fichier fait un essai, tu verras.

voila c'est tout

bonne soirée et ne te mets en retard pour le souper si tu veux rester parmi les vivants ihihihi je blague bien sur

je ne vais pas tarder non plus madame a déja la tète dans les épaules , pas bon ca.

Salut Raymond