vb label的Caption的文字实现上下滚动

[lwj_1986]

就想电影屏幕上面那样能

从下面往上面滚动

这样循环

一直没想出来

是不是用label.height呢

谢谢 希望能给出实例

[jikun6666]

很佩服 cbm666

[东方之珠]

picture控件+Timer控件+label控件=平滑移动

[东方之珠]

'在窗体Form1上面放上一个Picture1，picture1上面放上一个Label1，在窗体上再放上一个计时器Timer1
Option Explicit

Private Sub Form_Load()
        Label1.Caption = "2008年奥运会即将来临"
        Timer1.Enabled = True
        Timer1.Interval = 10 '调整这个值可控制标签label1的移动速度
         Picture1.ScaleMode = 3
        Me.ScaleMode = 3
        Picture1.Picture = LoadPicture("D:\bliss.jpg")
End Sub

Private Sub Timer1_Timer()
        If Label1.Top <= 0 Then Label1.Top = Picture1.ScaleHeight
        Label1.Top = Label1.Top - 1
End Sub

[爱我的人请呼吸]

楼上的代码在LABEL的TOP=0时就会从底部重新开始移动

有种跳跃的感觉

Private Sub Timer1_Timer()
        If Label1.Top <= 0-Label1.Top Then Label1.Top = Picture1.ScaleHeight
        Label1.Top = Label1.Top - 1
End Sub

改了一下。HOO~

[嗷嗷叫的老马]

差不多该结了吧.

[舉杯邀明月]

来看一下...........

[用户 昵称]

用一个picture来实现。

[cbm6666]

'添加Timer1 Label1 Label2 Image1(0) Image1(1)
'Image1(0)与image1(1)是两张同样大小画面稍不同并叠在一起的图片, 用来做退出的小图片.
'Me.picture自己加一张背景图片

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1
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) As Long
'*****************************************移动窗体
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
'****************************************圆矩窗体
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
'*************************************************************
Dim xx1%, yy1%, xx2%, yy2%, rtn&, aa$, lw&, lh&
Private Sub Form_Load()
With Me
.AutoRedraw = True
.BorderStyle = 0
.Caption = ""
.Width = 9090
.Height = 7125
.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
End With
With Label1
.BackStyle = 0
.AutoSize = True
.Font = "楷体_GB2312"
.FontSize = 24
.ForeColor = QBColor(10)
.Caption = "欢迎观赏 CBM666 的标签不闪滚动测试"
.Left = Me.Width
.Top = Me.Height - Label1.Height - 200
End With
aa = " CBM666的电影卷幕" & Chr(10) & vbCrLf
aa = aa & "不闪的标签要如何作?" & Chr(10) & vbCrLf
aa = aa & " 要代码的留下邮箱"
With Label2
.BackStyle = 0
.AutoSize = True
.Font = "楷体_GB2312"
.FontSize = 24
.ForeColor = QBColor(11)
.Caption = aa
.Left = (Me.Width - Label2.Width) \ 2
.Top = Me.Height
End With
xx1 = Label1.Left: yy1 = Label1.Top
xx2 = Label2.Left: yy2 = Label2.Top
Image1(0).Move Me.Width - Image1(0).Width - 200, Me.Height - Image1(0).Height - 600
Image1(1).Move Image1(0).Left, Image1(0).Top
Image1(0).ZOrder 0
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, 255, LWA_COLORKEY And LWA_ALPHA
lw = Me.Width \ Screen.TwipsPerPixelX
lh = Me.Height \ Screen.TwipsPerPixelY
SetWindowRgn hwnd, CreateRoundRectRgn(0, 0, lw, lh, 36, 36), True
Timer1.Enabled = True
Timer1.Interval = 20
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image1(0).Visible = True
If Button = 1 Then
MousePointer = 5
Call ReleaseCapture
lngReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
MousePointer = 0
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
rtn = MsgBox("确认要退出程序吗？", vbYesNo, "退出确认")
If rtn = vbNo Then
Cancel = -1
Else
End
End If
End Sub

Private Sub Image1_Click(Index As Integer)
Unload Me
End Sub

Private Sub image1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Image1(0).Visible = False
End Sub

Private Sub Timer1_Timer()
xx1 = IIf(xx1 <= -Label1.Width, Me.Width, xx1 - 60)
yy2 = IIf(yy2 <= -Label2.Height, Me.Height, yy2 - 40)
Label1.Move xx1, yy1
Label2.Move xx2, yy2
End Sub


效果图:
http://p.blog.csdn.net/images/p_blog_csdn_net/cbm666/366646/o_JZT.gif

[lwj_1986]

很 厉害 呵呵

我有一点不 明白的是 为什么在每个人的回复中一定要加个PICTURE呢？

不加图片不可以么？


我自己写好了 就没加图片

[东方之珠]

当然，可以不加！
加picture的好处是：移动时，上、下都有一段空间，让人可以接受，这是艺术！我们平时写字都要求上下都留点空白吧！不要从地上一冒出来，就捅到天上去，这样不好！

[ChamPagneZ]

MARK

[lwj_1986]

哦 也许吧 呵呵