Soyez le premier à donner votre avis sur cette source.
Vue 14 814 fois - Téléchargée 2 178 fois
'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 ' ' '
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.