sub changcolor(LCnt as Control,color1 As Integer,_
color2 As Integer,color3 As Integer,color4 As Integer,color5 As Integer,color6 As Integer,_color7 as integer,color8 as integer)
Dim tmep as integer
tmep=val(LCnt.tag)
select case tmep
case color1
Lcnt.tag=color2
case color2
lcnt.tag=color3
case color3
lcnt.tag=color4
case color4
lcnt.tag=color5
case color5
lcnt.tag=color6
case color6
lcnt.tag=color7
case color7
lcnt.tag=color8
case color8
lcnt.tag=color1
end select
lcnt.forcolor=QBcolor(lcnt.tag)
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
Private 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
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Timer1_Timer()
Label1.Top = Label1.Top - 100
'通过改变Label1的Top属性实现滚动效果
If Label1.Top <0 Then Label1.Top= screen.height
'当Label1移出窗口后使它的height属性变为0,实现循环!
End Sub
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
Const MoveStep = 2
Const MoveDelay = 50
Dim intPos As Long
Private Sub Command1_Click()
Dim i As Integer
picSource.Picture = LoadPicture("c:\winnt\Soap Bubbles.bmp")
picSource.Width = picShow.Width
picSource.Height = picShow.Height * 2 '这个值应该大到足够容纳下所有行的内容
picSource.ScaleMode = vbPixels
picSource.AutoRedraw = True
picSource.Visible = False
For i = 1 To 100
picSource.Print "Line" & i
Next i
intPos = 0
picShow.ScaleMode = vbPixels
picShow.AutoRedraw = True
Timer1.Interval = MoveDelay
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
BitBlt picShow.hDC, 0, 0, picShow.ScaleWidth, picShow.ScaleHeight, picSource.hDC, 0, intPos, vbSrcCopy
intPos = intPos + MoveStep
If intPos > picSource.ScaleHeight Then
Timer1.Enabled = False
End If
picShow.Refresh
End Sub