Texte défilant dans le style bannière (ocx)

Télécharger le projet
Commenter

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.

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
'
'
'
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.