VB实现公告栏功能（上下滚动显示）问题

[szyss]

各位好，要实现公告拦功能，上下能滚动。
如下：
18:00 1号房 黄金甲
18:30 2号房 ...
20:30 1号房 ...

用户可以自己控制字体大小及滚动速度。

请问该怎么处理呢？
多谢！

[VBToy]

用定时器控制label控件移动.label的字体大小可以设置。

[teaco2007]

我有个想法，不用什么高档控件就用最简单的基本控件Label

如果要三行一显示，就用三个Label
用一个定时器，定时到时，Label1显示Label2，Label2显示Label3，Label3显示Label1就可以了
速度嘛调节定时间隔，字体大小改变Label的字体就行了。
如果文字内容也要变化的话，就可以放在一个文件中，读到Label中就可以了。
不知LZ满意这个方法吗?

[szyss]

TO teaco2007()：多谢。还有以下问题
我初步是想在一个FRM中给用户填写信息，然后点确定后，弹出另有一无框的窗口来显示用户填写的那些信息。

但是如果用户字体调大、调小了，那么LABEL怎么根着字体的大小而改变高度
用户定义要显示的LABLE数是不定了。
请问怎么解决以上问题。多谢！

[zq972]

'************************************************************
'*程序编号∶030
'*功 能∶本程序演示了如何在图片上移动文字
'*日 期∶4/19/1999
'************************************************************
Option Explicit

Private Const SRCCOPY& = &HCC0020
Private Const SRCAND& = &H8800C6

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long)
Private 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)

Private isBack As Boolean
Private Sub BackText()
Picture1.FontName = "宋体"
Picture1.FontBold = True
Picture1.FontSize = 25
Picture1.Cls
PrintText "感谢您的支持"
PrintText "vbbattlefront"
PrintText "永远记着您"
End Sub

Private Sub PrintText(StrText As String)

Static X As Long
Static y As Long
Dim dl As Long
X = (Picture1.Width - Picture1.TextWidth(StrText)) \ 2
y = y + Picture1.TextHeight(StrText) + 5
dl& = TextOut(Picture1.hDC, X, y, StrText, LenB(StrConv(StrText, vbFromUnicode)))

End Sub
Private Sub BackPic()
Dim dl As Long
Dim y As Long

y = (PicOut.Height - Picture1.Height) \ 2
dl& = BitBlt(PicBack.hDC, 0, 0, PicBack.Width, PicBack.Height, PicOut.hDC, 0, y, SRCCOPY)
End Sub
Private Sub PlayOutText()
Dim dY As Long
Dim dl As Long
Dim y As Long

dY = (PicOut.Height - Picture1.Height) \ 2
For y = -Picture2.Height To Picture2.Height
Picture2.Cls
dl& = BitBlt(Picture2.hDC, 0, 0, Picture2.Width, Picture2.Height, Picture1.hDC, 0, y, SRCCOPY)
dl& = BitBlt(Picture2.hDC, 0, 0, PicBack.Width, PicBack.Height, PicBack.hDC, 0, 0, vbSrcAnd)

Sleep 20
DoEvents
dl& = BitBlt(PicOut.hDC, 0, dY, Picture2.Width, Picture2.Height, Picture2.hDC, 0, 0, SRCCOPY)
Next
End Sub


Private Sub Command1_Click()
Command1.Enabled = False
If Not isBack Then
BackPic
BackText
isBack = True
End If
PlayOutText
Command1.Enabled = True
End Sub

Private Sub Form_Load()
Form1.ScaleMode = vbPixels
Picture1.ScaleMode = vbPixels
Picture2.ScaleMode = vbPixels
PicBack.ScaleMode = vbPixels
PicOut.ScaleMode = vbPixels

Picture2.Width = Picture1.Width
Picture2.Height = Picture1.Height
PicBack.Width = Picture1.Width
PicBack.Height = Picture1.Height

Picture1.AutoRedraw = True
Picture2.AutoRedraw = True
PicBack.AutoRedraw = True

End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub


要窗体文件的话留下mail

[zzyong00]

让label随着字体的大小而改变高度可用autosize
显标label个数不定，可用label动态数组

[szyss]

感谢各位的帮忙回答！
但是，不知是不是使用TIMER的缘故，屏幕显示LABEL总是会抖动的。

请问是什么原因，需要怎么解决呢？多谢！

[szyss]

感谢 zq972(热烈庆祝)－>(手机单向收费，吼吼~~~~) ！我的 EMAIL:[e-mail]

[韧恒]

滚动文本的代码如下:
'This example requires the following controls on a form:
' - PictureBox (name=Picture1, ClipControls=False)
' - TextBox (name=Text1)
' - CheckBox (name=Check1)
' - Three command buttons (Command1, Command2 and Command3)
' - A Common Dialog Box (CommonDialog1)

'*** In a form
' -----------------------------------------------------
' S C R O L L E R
' -----------------------------------------------------
' Note:
' Be sure that PictureBox font is same as TextBox font!
' ... and width.
' Set TextBox Multiline = True
' -----------------------------------------------------
Private TextLine() As String 'Text lines array
Private Scrolling As Boolean 'Scroll flag
Private Alignment As Long 'Text alignment
Private t As Long 'Timer counter (frame delay)
Private Index As Long 'Actual line index
Private RText As RECT 'Rectangle into each new text line will be drawed
Private RClip As RECT 'Rectangle to scroll up
Private RUpdate As RECT 'Rectangle to update (not used)
Private Sub Form_Load()
'Locate and resize controls
Me.Caption = "Scroller up"
Me.ScaleMode = vbPixels
Me.Move Me.Left, Me.Top, Screen.TwipsPerPixelX * 425, Screen.TwipsPerPixelX * 400
Picture1.ScaleMode = vbPixels
Picture1.Move 10, 10, 400, 300
Picture1.AutoRedraw = True
Text1.Move 10, 10, 400
Text1.Visible = False
Command1.Caption = "&Load txt file..."
Command1.Move 10, 320, 100, 25
Command2.Caption = "&Start"
Command2.Move 200, 320, 100, 25
Command3.Caption = "S&top"
Command3.Move 310, 320, 100, 25
Check1.Caption = "L&oop"
Check1.Move 200, 350
With Picture1
'Set rectangles
SetRect RClip, 0, 1, _
.ScaleWidth, .ScaleHeight
SetRect RText, 0, .ScaleHeight, _
.ScaleWidth, .ScaleHeight + .TextHeight("")
End With
'Center text (&H0 = Left, &H2 = Right)
Alignment = &H1
End Sub
Private Sub Command2_Click()
If Trim(Text1) = "" Then
MsgBox "Nothing to scroll", vbInformation, "Scroll"
Exit Sub
End If
'Start scroll
Command1.Enabled = False
Scrolling = True
Index = 0
Call Scroll
End Sub
Private Sub Command3_Click()
Scrolling = False
Command2.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Scrolling = False '!
End
End Sub
Private Sub Scroll()
Dim txt As String 'Text to be drawed
With Picture1
Do
'Periodic frames
If GetTickCount - t > 25 Then 'Set your delay here [ms]
'Reset timer counter
t = GetTickCount
'Line ( + spacing ) totaly scrolled ?
If RText.Bottom < .ScaleHeight Then
'Move down Text area out scroll area...
OffsetRect RText, 0, .TextHeight("") ' + space between lines [Pixels]
'Get new line
If Alignment = &H1 Then
'If alignment = Center, remove spaces
txt = Trim(TextLine(Index))
Else
'Case else, preserve them
txt = TextLine(Index)
End If
'Source line counter...
Index = Index + 1
End If
'Draw text
DrawText .hdc, txt, Len(txt), RText, Alignment
'Move up one pixel Text area
OffsetRect RText, 0, -1
'Finaly, scroll up (1 pixel)...
ScrollDC .hdc, 0, -1, RClip, RClip, 0, RUpdate
'...and draw a bottom line to prevent... (well, don't draw it and see what happens)
Picture1.Line (0, .ScaleHeight - 1)-(.ScaleWidth, .ScaleHeight - 1), .BackColor
'(Refresh doesn't needed: any own PictureBox draw method calls Refresh method)
End If
DoEvents
Loop Until Scrolling = False Or Index > UBound(TextLine)
End With
If Check1 And Scrolling Then Command2 = True
Command1.Enabled = True
End Sub
Private Sub Command1_Click()
'Choose file...
CommonDialog1.Filter = "Text files (*.txt)|*.txt"
CommonDialog1.DefaultExt = "*.txt"
CommonDialog1.Flags = cdlOFNHideReadOnly Or _
cdlOFNPathMustExist Or _
cdlOFNOverwritePrompt Or _
cdlOFNNoReadOnlyReturn
CommonDialog1.DialogTitle = "Select a file"
CommonDialog1.CancelError = True
On Error GoTo CancelOpen
CommonDialog1.ShowOpen
DoEvents
MousePointer = vbHourglass
'Load selected file...
Dim srcFile As String
Dim txtLine As String
Dim FF As Integer
FF = FreeFile
Open (CommonDialog1.FileName) For Input As #FF
While Not EOF(FF)
Line Input #FF, txtLine
srcFile = srcFile & txtLine & vbCrLf
Wend
Close #FF
'srcFile is passed to srcTextBox to set correct line breaks
Text1 = srcFile
SendMessage Text1.hwnd, EM_FMTLINES, True, 0 'Enables line adjusment
TextLine() = Split(Text1, vbCrLf)
SendMessage Text1.hwnd, EM_FMTLINES, False, 0 'Disables line adjusment
Picture1.Cls
MousePointer = vbCustom
Exit Sub

CancelOpen:
If Err.Number <> 7 Then Exit Sub
MousePointer = vbCustom
MsgBox "Unable to load file." & vbNewLine & vbNewLine & _
"Probably size exceeds TextBox maximum lenght (64Kb)", _
vbCritical, "Error"
End Sub

'*** In a module
Option Explicit
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long

Declare Function OffsetRect Lib "user32" _
(lpRect As RECT, _
ByVal X As Long, _
ByVal Y As Long) As Long
Declare Function ScrollDC Lib "user32" _
(ByVal hdc As Long, _
ByVal dx As Long, ByVal dy As Long, _
lprcScroll As RECT, _
lprcClip As RECT, _
ByVal hrgnUpdate As Long, _
lprcUpdate As RECT) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, _
ByVal lpStr As String, _
ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const EM_FMTLINES = &HC8
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type



最后给楼主提个醒: (因为我最近正在做一个滚动字幕的控件，所以遇到了这个问题)
如果你肯定这个滚动的控件只有几个（如五个以下）同时滚动，而且对定时要求不高，那么你使用Timer就可以了，但如果你来设计一个控件，你无法控制到底有多少控件同时滚动，也不能确定用户设置的滚动速度，那么你要注意这方面的问题，此时Timer就无能为力了。总之，这个问题中定时是关键。

[zq972]

已发送，请查收

[szyss]

感谢 zq972(热烈庆祝)－>(手机单向收费，吼吼~~~~) 的邮件！已经收到！