【CBM666 的不闪卡通】

【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)