【CBM666 的不闪动画】
'添加Timer1 Picture1
'保存下面两张图片到你的程序相同路径下(App.Path)
'大张的图片名称是 Girls.bmp 小秤台文件名是 BchScale.jpg
Option Explicit
Private Declare Function GdiTransparentBlt Lib "gdi32" (ByVal hdc1 As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) 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) As Long
Dim PicName$, PicNo%, AppDisk$, W&, H&, TransColor$, X1%, Y1%
Dim N%, L%, C$, UD As Boolean
Const Captions As String = "CBM666 的不闪动画"
Private Sub Form_Load()
AppDisk = IIf(Right(App.Path, 1) = "", App.Path, App.Path & "")
Me.AutoRedraw = True: Me.ScaleMode = 3: Me.Width = 7000: Me.Height = 5160
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
If Dir(AppDisk & "bchscale.jpg") <> "" Then Me.Picture = LoadPicture(AppDisk & "bchscale.jpg")
Picture1.AutoSize = True: Picture1.AutoRedraw = True
Picture1.BorderStyle = 0: Picture1.Move Screen.Width
PicName = AppDisk & "girls.bmp"
If Dir(PicName) = "" Then MsgBox "您缺少了 " & PicName & " 图片": Unload Me: Exit Sub
Picture1.Picture = LoadPicture(PicName)
W = Picture1.Width: H = Picture1.Height \ 6
Timer1.Interval = 100: Timer1.Enabled = True
TransColor = RGB(99, 0, 255)
PicNo = 1: X1 = 58: Y1 = 33
End Sub
Private Sub Timer1_Timer()
Me.Cls
GdiTransparentBlt Me.hDC, X1, Y1, W, H, Picture1.hDC, 0, 120 * (PicNo - 1), W, H, TransColor
PicNo = IIf(PicNo + 1 > 6, 1, PicNo + 1)
Y1 = IIf(UD, Y1 + 2, Y1 - 2)
UD = IIf(Y1 >= 66 Or Y1 <= 0, Not UD, UD)
'*********** 滚动标题栏
L = Int(Me.Width / 110)
C = String(L, " ") & Captions & String(L, " ")
N = N + 1
If N > Len(C) - L Then N = 1
Me.Caption = Mid(C, N, L)
End Sub
效果图:
保存到 App.Path 程序路径下 BchScale.jpg
保存到 App.Path 程序路径下 Girls.bmp
[解决办法]
阿弥陀佛!
善哉善哉!
[解决办法]
两个又干上了?、
[解决办法]
学习。。
另: 再这样干 估计又要像360和QQ一样了。
[解决办法]