Perds la couleur au défilement

eliot raymond · 14 Mai 2009

Bonjour a tous et toutes, forum bonjour,

Ce code (voir fichier) 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.

Si quelqu'un veut bien SVP se pencher dessus et me donner un petit coup de main, ca serai super sympa.

En tout cas merci a vous et de votre temps et bonne journée malgré la pluie

Raymond

PMO2 · 15 Mai 2009

Re : Perds la couleur au défilement

Bonjour,

Une solution avec le code suivant

Code:

Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)

Sub Tst_pmo()
Dim X As Long
Dim OldY1 As Long
Dim Y1 As Long
Dim OldY2 As Long
Dim Y2 As Long
Dim Z1 As Long
Dim Z2 As Long
Dim C As Range
Dim i As Long
[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].Font
  .FontStyle = "Normal"
  .ColorIndex = xlAutomatic
End With
X = 1
Y1 = InStr(InStr([a1], " ") + 2, [a1], " ") + 1
Y2 = InStr(InStr([a2], " ") + 12, [a2], " ") + 1
OldY1 = Y1
OldY2 = Y2
Z1 = Len([a1])
Z2 = Len([a2])
Custom [a1:a2].Characters(X, 1)
Custom [a1].Characters(Y1, 1)
Custom [a2].Characters(Y2, 1)

'*** CODE POUR LE DEFILEMENT DES DEUX MESSAGES CELLULES A1/A2
Set C = [a1]
Standard C
X = Z1 + 1
For i = 1 To 40
  X = X - 1
  If X = 0 Then
    X = Z1
    Standard C
  End If
  Y1 = Y1 - 1
  If Y1 = 0 Then
    Y1 = Z1
    Standard C
  End If
  C = Right(C, Z1 - 1) + Left(C, 1)
  Custom C.Characters(X, 1)
  Custom C.Characters(Y1, 1)
  Sleep 150
Next i
C = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))
Standard C
Custom C.Characters(1, 1)
Custom C.Characters(OldY1, 1)

Application.Wait (Now + TimeValue("00:00:03"))

Set C = [a2]
Standard C
X = Z2 + 1
For i = 1 To 45
  X = X - 1
  If X = 0 Then
    X = Z2
    Standard C
  End If
  Y2 = Y2 - 1
  If Y2 = 0 Then
    Y2 = Z2
    Standard C
  End If
  C = Right(C, Z2 - 1) + Left(C, 1)
  Custom C.Characters(X, 1)
  Custom C.Characters(Y2, 1)
  Sleep 150
Next i
C = "Semaine: " & DatePart("ww", Date, vbMonday) & "     " & _
     DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année"
Standard C
Custom C.Characters(1, 1)
Custom C.Characters(OldY2, 1)
End Sub

Sub Standard(ByRef R As Range)
With R.Font
  .ColorIndex = 0
  .Bold = False
End With
End Sub

Sub Custom(ByRef Ch As Characters)
With Ch.Font
  .FontStyle = "Gras"
  .ColorIndex = 3
End With
End Sub

Cordialement.

PMO
Patrick Morange

eliot raymond · 15 Mai 2009

Re : Perds la couleur au défilement

Bonjour PMO2, bonjour forum,

Tout d'abord merci pour le code et bravo, je crois savoir que ce n'est pas évident a faire, mais l'essentiel c'est que ca marche.

Une question SVP: Peut' on arrèter le défilement en cliquant dans une cellule n'étant pas concernée le temps d' écrire la ou on a besoin et de faire repartir le défilement après en cliquant a nouveau.

En tout cas encore un grand merci a toi.

Bonne après-midi et bon W-end

Raymond

PMO2 · 16 Mai 2009

Re : Perds la couleur au défilement

Bonjour,

Une nouvelle version qui prend en compte le fait de pouvoir continuer de travailler sur la feuille pendant que le défilement est en cours.

1) Copiez le code suivant dans la fenêtre de code de la feuille concernée (celle contenant le défilement)

Code:

Private Sub CommandButton1_Click()
If Not EnCours Then Call Tst_pmo
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not EnCours Then Call Tst_pmo
End Sub

Private Sub Worksheet_Deactivate()
EnCours = False
End Sub

Private Sub Worksheet_Activate()
If Not EnCours Then Call Tst_pmo
End Sub

2) Copiez le code suivant dans un module Standard

Code:

'### Constante du nom de la feuille concernée (à adapter) ###
Const FEUILLE As String = "test"
'############################################################
Public EnCours As Boolean

Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)

Sub Tst_pmo()
Dim S As Worksheet
Dim X As Long
Dim OldY1 As Long
Dim Y1 As Long
Dim OldY2 As Long
Dim Y2 As Long
Dim Z1 As Long
Dim Z2 As Long
Dim C As Range
Dim i As Long

On Error GoTo Erreur
EnCours = True
Application.Cursor = xlNorthwestArrow
Set S = Sheets(FEUILLE)
S.[a1] = Application.Proper(Format(Date, "dddd dd mmmm yyyy    "))
S.[a2] = "Semaine: " & DatePart("ww", Date, vbMonday) & "     " & _
     DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année" & "     "
With S.[a1:a2].Font
  .FontStyle = "Normal"
  .ColorIndex = xlAutomatic
End With
X = 1
Y1 = InStr(InStr(S.[a1], " ") + 2, S.[a1], " ") + 1
Y2 = InStr(InStr(S.[a2], " ") + 12, S.[a2], " ") + 1
OldY1 = Y1
OldY2 = Y2
Z1 = Len(S.[a1])
Z2 = Len(S.[a2])
Custom S.[a1:a2].Characters(X, 1)
Custom S.[a1].Characters(Y1, 1)
Custom S.[a2].Characters(Y2, 1)

'*** CODE POUR LE DEFILEMENT DES DEUX MESSAGES CELLULES A1/A2
Set C = S.[a1]
Standard C
X = Z1 + 1
For i = 1 To 40
  If Not EnCours Then Error 65530
  DoEvents
  X = X - 1
  If X = 0 Then
    X = Z1
    Standard C
  End If
  Y1 = Y1 - 1
  If Y1 = 0 Then
    Y1 = Z1
    Standard C
  End If
  C = Right(C, Z1 - 1) + Left(C, 1)
  Custom C.Characters(X, 1)
  Custom C.Characters(Y1, 1)
  Sleep 150
Next i
C = Application.Proper(Format(Date, "dddd dd mmmm yyyy"))
Standard C
Custom C.Characters(1, 1)
Custom C.Characters(OldY1, 1)

Application.Wait (Now + TimeValue("00:00:01"))

Set C = S.[a2]
Standard C
X = Z2 + 1
For i = 1 To 45
  If Not EnCours Then Error 65530
  DoEvents
  X = X - 1
  If X = 0 Then
    X = Z2
    Standard C
  End If
  Y2 = Y2 - 1
  If Y2 = 0 Then
    Y2 = Z2
    Standard C
  End If
  C = Right(C, Z2 - 1) + Left(C, 1)
  Custom C.Characters(X, 1)
  Custom C.Characters(Y2, 1)
  Sleep 150
Next i
C = "Semaine: " & DatePart("ww", Date, vbMonday) & "     " & _
     DatePart("y", Date, vbMonday) & " ième Jour de l" & Chr(180) & "année"
Standard C
Custom C.Characters(1, 1)
Custom C.Characters(OldY2, 1)
Erreur:
Application.Cursor = xlDefault
EnCours = False
End Sub

Sub Standard(ByVal R As Range)
With R.Font
  .ColorIndex = 0
  .Bold = False
End With
End Sub

Sub Custom(ByVal Ch As Characters)
With Ch.Font
  .FontStyle = "Gras"
  .ColorIndex = 3
End With
End Sub

Cordialement.

PMO
Patrick Morange

eliot raymond · 17 Mai 2009

Re : Perds la couleur au défilement

Bonjour Patrick, bonjour Forum

Merci pour le code, mais cela ne fonctionne tout a fait comme prévu, je vous explique le petit souci sur ma version XL 2007.

J'ai suivi avec attention les conseils d'installation, le code fonctionne bien. Lorsque je click dans une cellule pour écrire le défilement s'arrète bien, mais il ne repart pas lorsque j'ai fini d'écrire dans la dite cellule, mème en reclicquant, J'ai regarder mais snif sniff.

Voila encore merci pour cet excellent code, en attendant de vous relire, je vous souhaite un très bon Dimanche.

Raymond

PMO2 · 17 Mai 2009

Re : Perds la couleur au défilement

Bonjour,

J'ai programmé sur Excel 2003 et, ne disposant pas de Excel 2007, je n'ai pu faire des tests sur une version Excel plus récente.

Chez moi tout fonctionne comme attendu. Peut-être s'agit-il d'une différence entre versions d'Excel et, malheureusement, je ne vois pas de solution à apporter.

Bon courage.

Cordialement.

PMO
Patrick Morange

eliot raymond · 17 Mai 2009

Re : Perds la couleur au défilement

Bonsoir Patrick, forum

Merci d'avoir regarder de nouveau votre code, tant pis, j'espère peut etre que quelqu'un pourra regarder pourquoi il ne fonctionne pas complètement sur excel 2007.

En tout cas merci a vous, et de votre temps passer pour la réalisation de ce code et si toutes fois une idée qui permettrai de finaliser, je suis preneur.

Bonne fin d'après midi a vous et bon courage pour cette semaine.

Raymond

eliot raymond · 18 Mai 2009

Re : Perds la couleur au défilement

Bonjour Patrick, forum bonjour

Je voulais vous demander s'il vous serait possible SVP de me commenter le dernier code que avez réaliser, ceci afin que j'essai de comprendre un peu mieux car étant débutant le code est un peu compliquer pour moi et je voudrais bien qu'il fonctionne pour l'adapter a mon programme sur Excel 2007.

Je n'ai plus la version Excel 2003 sinon je l'aurai essayer afin de voir le résultat final.

Merci a vous par avance bonne semaine et bonne journée.

Raymond

PMO2 · 20 Mai 2009

Re : Perds la couleur au défilement

Bonjour Raymond,

La solution que j'ai précédemment fait paraître n'a pas l'air d'être une panacée. Elle bloque parfois pour des raisons que je n'ai pu déterminer.
D'autre part, l'usage du copier coller n'est pas autorisé.

Si vous êtes toujours intéressé j'ai développé, d'une toute autre manière, un programme qui semble plus satisfaisant mais, qui étant très compliqué, est difficile à expliquer. Faites moi signe dans l'affirmative.

Cordialement.

PMO
Patrick Morange

eliot raymond · 20 Mai 2009

Re : Perds la couleur au défilement

Bonsoir Patrick, forum bonsoir,

Merci pour la réponse c'est sympa, je viens de prendre connaissance de votre offre, je suis bien entendu preneur, je vous rappelle que je suis sous excel 2007 aussi, peut etre que cela ne va pas etre possible.

Merci a vous, je vous souhaite une bonne soirée.

Raymond

Cousinhub · 20 Mai 2009

Re : Perds la couleur au défilement

Bonsoir,

ayant testé ton code sur 2003 et 2007, je ne rencontre pas les soucis d'eliot..

tout fonctionne parfaitement, chez moi....

Même sous 2007, en écrivant dans une cellule, le défilement s'arrête, puis repart
si le défilement est arrêté, le fait d'écrire dans une cellule, puis de valider par Entrée, fait repartir le défilement....

😕😕

eliot raymond · 20 Mai 2009

Re : Perds la couleur au défilement

Bonsoir bhbh, forum

J'ai lu ta réponse, j'ai essayer de nouveau et je n'ai pas ta chance, ca ne marche toujours pas, peut etre une option ou autre, merci d'avoir essayer, on ai sur la bonne voie.

merci bonne soirée a toi

Raymond

PMO2 · 20 Mai 2009

Re : Perds la couleur au défilement

Bonjour à tous,

Voici une autre méthode, maleureusement bien plus compliquée, qui au lieu d'utiliser des cellules (A1:A2) passe par l'usage d'un UserForm.
On peut gérer la transparence de ce dernier et donc entrapercevoir le contenu des cellules se situant en-dessous.

1) Créez un UserForm1 avec un Label1 et un Label2
2) Dans sa fenêtre de code copiez le code suivant

Code:

Private Sub Label1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Unload Me
End Sub

Private Sub Label2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Unload Me
End Sub

Sub Defilement()
Dim X&
Dim OldY1&
Dim Y1&
Dim OldY2&
Dim Y2&
Dim Z1&
Dim Z2&
Dim i&
X& = 1
Y1& = InStr(InStr(Label1, " ") + 2, Label1, " ") + 1
Y2& = InStr(InStr(Label2, " ") + 12, Label2, " ") + 1
OldY1& = Y1&
OldY2& = Y2&
Z1& = Len(Label1)
Z2& = Len(Label2)
X& = Z1& + 1
Application.EnableCancelKey = xlDisabled
Do Until Not EnCours
  DoEvents
  Label1.ForeColor = &HFFFFFF
  For i& = 1 To Z1&
    If Not EnCours Then Exit For
    DoEvents
    X& = X& - 1
    If X& = 0 Then X& = Z1&
    Y1& = Y1& - 1
    If Y1& = 0 Then Y1& = Z1&
    Label1 = Right(Label1, Z1& - 1) + Left(Label1, 1)
    Sleep 150
  Next i&
  Label1.ForeColor = &HFFFF&
  Label2.ForeColor = &HFFFFFF
  For i& = 1 To Z2&
    If Not EnCours Then Exit For
    DoEvents
    X& = X& - 1
    If X& = 0 Then X& = Z2&
    Y2& = Y2& - 1
    If Y2& = 0 Then Y2& = Z2&
    Label2 = Right(Label2, Z2& - 1) + Left(Label2, 1)
    Sleep 150
  Next i&
  Label2.ForeColor = &HFFFF&
Loop
Exit Sub
End Sub

Private Sub UserForm_Activate()
Call Defilement
End Sub

Private Sub UserForm_Initialize()
Dim Handle&
With Me.Label1
  .BackColor = &H80000002
  .Caption = Application.Proper(Format(Date, "dddd dd mmmm yyyy    "))
  .AutoSize = True
  .Width = .Width + 50
  .AutoSize = False
  .Height = 20
  .Left = 0
  .Top = 0
  .ForeColor = &HFFFF&
  .Font.Bold = True
  .TextAlign = fmTextAlignCenter
End With
With Me.Label2
  .BackColor = &H80000002
  .Caption = "Semaine: " & DatePart("ww", Date, vbMonday) & "     " & _
     DatePart("y", Date, vbMonday) & " ème Jour de l" & Chr(180) & "année " & " "
  .AutoSize = True
  .Width = .Width + 50
  .AutoSize = False
  .Height = 20
  .Left = Label1.Width
  .Top = 0
  .ForeColor = &HFFFF&
  .Font.Bold = True
  .TextAlign = fmTextAlignCenter
End With
With Me
  .StartUpPosition = 0
  .Width = Label1.Width + Label2.Width
  .Height = Label1.Height + 17
  .Left = Application.Width - .Width - 60
  Handle& = GetHandleUSF(.Caption)
      '--- Opacité=100 Transparence totale=0 ---
  Call Transparence(Handle&, 30)
      '-----------------------------------------
  Call SupprBarreTitreUF(Handle&)
  
'### Position du UserForm à adapter (flaguer l'option non retenue) ###
''  .Top = 0                                  'UserForm tout en haut
  .Top = Application.Height - .Height - 50  'UserForm tout en bas
'#####################################################################
End With
EnCours = True
End Sub

Private Sub UserForm_Terminate()
EnCours = False
End Sub

3) Dans un module Standard copiez le code suivant

Code:

Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function SetLayeredWindowAttributes& Lib "user32.dll" ( _
  ByVal hwnd As Long, ByVal crKey As Long, _
  ByVal bAlpha As Byte, ByVal dwFlags As Long)
Public Declare Function SetWindowLong& Lib "user32.dll" Alias "SetWindowLongA" ( _
  ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)
Public Declare Function FindWindowA& Lib "user32" ( _
  ByVal lpClassName As String, ByVal lpWindowName As String)
Public Declare Function GetWindowLong& Lib "user32.dll" Alias "GetWindowLongA" ( _
   ByVal hwnd As Long, ByVal nIndex As Long)
Public Declare Function GetWindowRect& Lib "user32.dll" ( _
   ByVal hwnd As Long, ByRef lpRect As typeRect)
Public Declare Function GetSystemMetrics& Lib "user32.dll" ( _
   ByVal nIndex As Long)
Public Declare Function MoveWindow& Lib "user32.dll" ( _
   ByVal hwnd As Long, ByVal X As Long, ByVal y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long)
 
Public Const GWL_STYLE = -16
Public Const WS_CAPTION = &HC00000
Public Const SM_CYCAPTION = 4
Public Const WS_EX_LAYERED As Long = &H80000
Public Const LWA_ALPHA As Long = &H2
Public Const GWL_EXSTYLE As Long = -20

Public Type typeRect
  X1 As Long
  Y1 As Long
  X2 As Long
  Y2 As Long
End Type

Public EnCours As Boolean

Sub SupprBarreTitreUF(ByVal hwnd As Long)
Dim OldStyle&
Dim NewStyle&
Dim rct As typeRect
Dim dx&
Dim dy&
'---- Obtient le style de fenêtre courant du formulaire ----
OldStyle& = GetWindowLong(hwnd, GWL_STYLE)
'---- Désactive le bit qui affiche la barre de titre ----
NewStyle& = OldStyle& And Not WS_CAPTION
'---- Définit le nouveau style de fenêtre ----
OldStyle& = SetWindowLong(hwnd, GWL_STYLE, NewStyle&)
'---- Taille courante y compris la barre de titre ----
Call GetWindowRect(hwnd, rct)
'---- Calcul des nouvelles largeur et hauteur ----
dx& = rct.X2 - rct.X1
dy& = rct.Y2 - rct.Y1 - _
GetSystemMetrics(SM_CYCAPTION)
'---- Déplace la fenêtre vers la même position TopLeft ----
Call MoveWindow(hwnd, rct.X1, rct.Y1, dx&, dy&, True)
End Sub

Public Sub Transparence(ByVal hwnd As Long, ByVal alpha As Long)
SetWindowLong hwnd, GWL_EXSTYLE, WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, 0, 255 * alpha / 100, LWA_ALPHA
End Sub

Function GetHandleUSF(ByVal UFcaption As String) As Long
GetHandleUSF = FindWindowA(vbNullString, UFcaption)
End Function

4) Dans la fenêtre de code de ThisWorkbook copiez le code suivant

Code:

Private Sub Workbook_Activate()
UserForm1.Show  (vbModeless)
End Sub

Private Sub Workbook_Deactivate()
If EnCours Then Unload UserForm1
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Not EnCours Then UserForm1.Show  (vbModeless)
End Sub

Ne lancez pas le programme à partir du VBE (éditeur Visual Basic). Il suffit de cliquer dans une nouvelle cellule pour que le programme démarre.
Pour stopper le programme double cliquez sur l'UserForm.

Bon courage.

Cordialement.

PMO
Patrick Morange

eliot raymond · 21 Mai 2009

Re : Perds la couleur au défilement

Bonjour Patrick, bonjour forum,

Je viens de voir le code houla, trop costaud pour moi, je mettrai ca plus tard en oeuvre car la ca dépasse mes compétences. Je vais bien étudier ensuite j'essairai.

En tout cas merci de vous etre pencher sur le code, je n'abandonne pas mais la ca demande réflextion et un peu de temps.

Encore merci je vous souhaite une très bonne journée

Raymond

PMO2 · 21 Mai 2009

Re : Perds la couleur au défilement

Bonjour à tous,

Pour ceux qui ont téléchargé la pièce jointe, je leur signale que j'y ai apporté une modification en ajoutant à la méthode Show du formulaire le paramètre (vbModeless).
Celui-ci étant omis précédemment et si, à la création du UserForm, la propriété ShowModal = True alors on ne pouvait pas reprendre la main dans Excel (sélectionner une autre cellule par exemple).

Le message précédent et sa pièce jointe ont donc été modifiés.
Merci de vous y reporter.

Cordialement.

PMO
Patrick Morange

Perds la couleur au défilement

eliot raymond

XLDnaute Occasionnel

Pièces jointes

PMO2

XLDnaute Accro

eliot raymond

XLDnaute Occasionnel

PMO2

XLDnaute Accro

eliot raymond

XLDnaute Occasionnel

PMO2

XLDnaute Accro

eliot raymond

XLDnaute Occasionnel

eliot raymond

XLDnaute Occasionnel

PMO2

XLDnaute Accro

eliot raymond

XLDnaute Occasionnel

Cousinhub

XLDnaute Barbatruc

eliot raymond

XLDnaute Occasionnel

PMO2

XLDnaute Accro

eliot raymond

XLDnaute Occasionnel

PMO2

XLDnaute Accro

Discussions similaires

Perds la couleur au défilement

XLDnaute Occasionnel

Pièces jointes

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency