TEXTE DÉFILANT DANS LE STYLE BANNIÈRE (OCX)

'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
'
'
'