Texte défilant dans le style bannière (ocx)
Soyez le premier à donner votre avis sur cette source.
Vue 14 814 fois - Téléchargée 2 178 fois
Description
Après plusieurs semaines de recheche, j'ai enfin trouver un code qui me permet à partir d'un fichier de faire défiler du texte avec un départ à droite, gauche, haut ou bas.
Appelé sous forme d'un OCX, il est facilement paramètrable et consomme très peu de ressource.
Je représise tout de même que le code d'origine n'est pas de moi.
Appelé sous forme d'un OCX, il est facilement paramètrable et consomme très peu de ressource.
Je représise tout de même que le code d'origine n'est pas de moi.
Source / Exemple :
'Créer un module nommé modBanner et coller le code suivant :
'
'
Option Explicit
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020
'
'#################################################################################################"
'
'Puis créer un contrôle utilisateur nommé textBanner et coller le code suivant :
'
'
Option Explicit
Private banX&, banY&, banHeight&, banWidth&
Private m_Scrolltext As String
Private m_backColor As OLE_COLOR, m_foreColor As OLE_COLOR
Private m_speed As Integer
Private m_scrollMode As Integer
Dim retVal As Long
Private WithEvents m_Font As StdFont
Private Sub setDim(vNewValue As Variant)
On Error GoTo err
picBuffer.Height = picBuffer.TextHeight(vNewValue) + 5
picBuffer.Width = picBuffer.TextWidth(vNewValue) + 10
picBuffer.Cls
Exit Sub
err:
Resume Next
End Sub
Public Property Get scrollText() As Variant
scrollText = m_Scrolltext
End Property
Public Property Let scrollText(ByVal vNewValue As Variant)
On Error GoTo err
m_Scrolltext = " " & vNewValue & " "
banX = picBanner.ScaleLeft
banY = picBanner.ScaleTop
picBanner.Cls
banHeight = picBuffer.ScaleHeight
banWidth = picBuffer.ScaleWidth
Call setDim(vNewValue)
picBuffer.Print vNewValue
Exit Property
err:
Resume Next
End Property
Public Sub scrollOn()
Timer1.Enabled = True
End Sub
Public Sub scrollOff()
Timer1.Enabled = False
End Sub
Private Sub picBanner_Click()
Timer1.Enabled = Not (Timer1.Enabled)
End Sub
Private Sub Timer1_Timer()
banHeight = picBuffer.ScaleHeight
banWidth = picBuffer.ScaleWidth
retVal = BitBlt(picBanner.hDC, banX, banY, _
banWidth, banHeight, _
picBuffer.hDC, 0, 0, SRCCOPY)
picBanner.Refresh
Select Case scrollMode
Case 0:
banX = banX - 1
If banX < 0 - banWidth Then
banX = picBanner.ScaleLeft + picBanner.ScaleWidth
End If
Case 1:
banX = banX + 1
If banX > picBanner.ScaleLeft + picBanner.ScaleWidth Then
banX = 0 - banWidth
End If
Case 2:
banY = banY - 1
If banY < (0 - picBuffer.ScaleHeight) Then
banY = picBanner.ScaleTop + picBanner.ScaleHeight
End If
Case 3:
banY = banY + 1
If banY > (picBanner.ScaleTop + picBanner.ScaleHeight) Then
banY = 0 - picBuffer.Height
End If
End Select
End Sub
Private Sub UserControl_Initialize()
Set m_Font = New StdFont
Set UserControl.font = m_Font
picBanner.ZOrder 0
picBanner.ScaleMode = vbPixels
UserControl.ScaleMode = vbPixels
picBuffer.ScaleMode = vbPixels
picBuffer.AutoRedraw = True
picBanner.AutoRedraw = True
backColor = vbBlue
foreColor = vbYellow
picBuffer.font = "Arial"
picBanner.font = "Arial"
speed = 30
scrollMode = 0
picBuffer.font.Bold = True
picBuffer.font.Size = 10
scrollText = "Scrolling Banner Control : Please place your own text inside here."
picBuffer.Print scrollText
End Sub
Public Property Get backColor() As OLE_COLOR
backColor = m_backColor
End Property
Public Property Let backColor(ByVal vNewValue As OLE_COLOR)
On Error GoTo err
m_backColor = vNewValue
picBuffer.Cls
picBuffer.backColor = vNewValue
picBanner.backColor = vNewValue
picBuffer.Print scrollText
PropertyChanged "backColor"
Exit Property
err:
Resume Next
End Property
Public Property Get foreColor() As OLE_COLOR
foreColor = m_foreColor
End Property
Public Property Let foreColor(ByVal vNewValue As OLE_COLOR)
On Error GoTo err
m_foreColor = vNewValue
picBuffer.Cls
picBuffer.foreColor = vNewValue
picBanner.foreColor = vNewValue
picBuffer.Cls
picBuffer.Print scrollText
PropertyChanged "foreColor"
Exit Property
err:
Resume Next
End Property
Private Sub UserControl_Paint()
picBuffer.font.Size = m_Font.Size
Call setDim(scrollText)
picBuffer.Print scrollText
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
On Error GoTo err
speed = PropBag.ReadProperty("speed", "")
font = PropBag.ReadProperty("font", "")
scrollText = PropBag.ReadProperty("scrollText", "")
backColor = PropBag.ReadProperty("backColor", "")
foreColor = PropBag.ReadProperty("foreColor", "")
Exit Sub
err:
Resume Next
End Sub
Private Sub UserControl_Resize()
If UserControl.Height > 5000 Then
UserControl.Height = 5000
ElseIf UserControl.Width > 19000 Then
UserControl.Width = 19000
End If
picBanner.Width = UserControl.ScaleWidth
picBanner.Height = UserControl.ScaleHeight
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
On Error GoTo err
PropBag.WriteProperty "speed", speed, "default"
PropBag.WriteProperty "font", font, "default"
PropBag.WriteProperty "scrollText", scrollText, "default"
PropBag.WriteProperty "backColor", backColor, "default"
PropBag.WriteProperty "foreColor", foreColor, "default"
Exit Sub
err:
Resume Next
End Sub
Public Property Get font() As StdFont
Set font = m_Font
End Property
Public Property Let font(ByVal vNewValue As StdFont)
With m_Font
.Bold = vNewValue.Bold
.Italic = vNewValue.Italic
.Name = vNewValue.Name
.Size = vNewValue.Size
End With
PropertyChanged "font"
picBuffer.font = m_Font
picBanner.Cls
Call setDim(scrollText)
picBuffer.Print scrollText
End Property
Private Sub m_Font_FontChanged(ByVal PropertyName As String)
Set UserControl.font = m_Font
Call setDim(scrollText)
picBanner.Cls
picBuffer.Print scrollText
Refresh
End Sub
Public Property Get speed() As Variant
speed = m_speed
End Property
Public Property Let speed(ByVal vNewValue As Variant)
If vNewValue > 0 And vNewValue < 51 Then
m_speed = vNewValue
Timer1.Interval = 51 - vNewValue
ElseIf vNewValue = "" Then
m_speed = 30
Timer1.Interval = 51 - 30
Else
err.Raise vbObjectError + 512, , "Speed out of range (1-50)" & vNewValue
End If
End Property
Public Property Get scrollMode() As Variant
scrollMode = m_scrollMode
End Property
Public Property Let scrollMode(ByVal vNewValue As Variant)
If vNewValue >= 0 Or vNewValue <= 4 Then
m_scrollMode = vNewValue
End If
End Property
'
'#################################################################################################"
'
'Pour la mise en forme voir le ZIP
'
'
'
Codes Sources
A voir également
- Bannière stylé
- Banniere styler - Meilleures réponses
- Graph : Bannière stylé - CodeS SourceS - Guide
- Banniere style - Guide
- Créez facilement une bannière animée en jquery ! - Conseils pratiques - Javascript
- Programme python stylé - Guide
- Delphi font style ✓ - Forum - Delphi / Pascal
28 déc. 2010 à 00:31
Balise:
<marquee bgcolor="#FFFFFF" direction="left" width="100%" height="20" valign="middle" scrollamount="2" scrolldelay="30">La solution n'est pas toujours aussi complique qu'on le pense.</marquee>
Cela facilitera la vie de plus d'un je penses.
Bon continuation,
J.R.
3 juil. 2006 à 12:06
Je suis certain que ton prg est opérationnel, mais moi, je n'arrive pas à le faire fonctionner.
Je charge l'ocx, c'est OK, mais lorsque j'exécute j'ai le msg "Format de fichier incorrect".
C'est dû à quoi et y a-t-il une solution ?
18 avril 2006 à 16:58
Je voulais simplement dire que votre code source est intéressant. Je suis débutant (je n'ai même pas fini ma formation), il me permet donc d'approfondir mes connaissances. Alors bravo et merci...
Origamiste
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.