帮忙添加一部分可以实现缩放
麻烦大家在程序里加以部分，可以实在图片一边运动一边缩放的效果 谢谢！Option Explicit
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 StretchBlt Lib "GDI32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020
Const SRCAND = &H8800C6
Const SRCPAINT = &HEE0086
Const CelWidth = 60 '动画的宽度
Const CelHeight = 100 '动画的高度
Const CelCount = 3 '动画帧的个数
Dim CelNum As Long 'CelNum 为当前的动画帧
Dim Forward As Long '蝴蝶从左向右飞/从右向左飞的标志
Dim Down As Long '蝴蝶从上向下飞/从下向上飞的标志
Dim CurrentLeft As Long ' 动画帧的X坐标
Dim CurrentTop As Long ' 动画帧的Y坐标
Dim OldLeft As Long ' 上一次动画帧的X坐标
Dim OldTop As Long ' 上一次动画帧的Y坐标
Function MaxSingle(A As Single, B As Single) As Single '求单精度变量A、B的最大值
If A > B Then
MaxSingle = A
Else
MaxSingle = B
End If
End Function
Function MinSingle(A As Single, B As Single) As Single '求单精度变量A、B的最小值
If A < B Then
MinSingle = A
Else
MinSingle = B
End If
End Function
Private Sub form1_Paint()
Dim temp As Long
Dim SrcWidth As Long
Dim CurrentX As Long
If Forward Then '当蝴蝶从左向右飞时
SrcWidth = CelWidth
CurrentX = CurrentLeft
Else '当蝴蝶从右向左飞时，SrcWidth应设置成负值，蝴蝶将掉头
SrcWidth = -CelWidth
CurrentX = CurrentLeft + CelWidth - 1
End If
temp = BitBlt(Form1.hDC, OldLeft, OldTop, CelWidth, CelHeight, BufferPicture.hDC, 0, 0, SRCCOPY)
temp = BitBlt(BufferPicture.hDC, 0, 0, CelWidth, CelHeight, Form1.hDC, CurrentLeft, CurrentTop, SRCCOPY)
temp = StretchBlt(Form1.hDC, CurrentX, CurrentTop, SrcWidth, CelHeight, SpritePic.hDC, CelNum * CelWidth, CelHeight + 5, CelWidth, CelHeight, SRCAND)
temp = StretchBlt(Form1.hDC, CurrentX, CurrentTop, SrcWidth, CelHeight, SpritePic.hDC, CelNum * CelWidth, 0, CelWidth, CelHeight, SRCPAINT)
OldLeft = CurrentLeft
OldTop = CurrentTop
0
CelNum = CelNum + 1 '动画帧计数
If CelNum > CelCount - 1 Then CelNum = 0 '动画显示到最后一帧时，将CelNum置为0
BufferPicture.Refresh '本条语句使我们能看到BitBlt（）的处理过程，它是可选的
End Sub
Private Sub Form_Activate()
Dim temp As Long
CelNum = 0
Form1.Picture = LoadPicture(App.Path & "\5.jpg")
SpritePic.Picture = LoadPicture(App.Path & "\6.jpg")
Form1.Refresh '本条语句很重要，它将窗体的背景图像刷新
temp = BitBlt(BufferPicture.hDC, 0, 0, CelWidth, CelHeight, Form1.hDC, CurrentLeft, CurrentTop, SRCCOPY)
End Sub
Private Sub Form_Load()
Forward = True
Down = True
CurrentLeft = 0
CurrentTop = 0
End Sub
Private Sub Timer1_Timer()
Dim border As Single '窗口边界
'蝴蝶遇到窗口边界时颠倒运动方向
If (((CurrentLeft + CelWidth) >= Form1.ScaleWidth - 9 * CelWidth) And Forward) Then
Forward = False
ElseIf ((CurrentLeft <= 0) And Not Forward) Then
Forward = True
End If
'计算蝴蝶的X坐标
If Forward Then
border = Form1.ScaleWidth - CelWidth
CurrentLeft = MinSingle(CurrentLeft + 15, border)
Else
border = CelWidth
CurrentLeft = MaxSingle(CurrentLeft - 15, 0)
End If
'判断蝴蝶是否超出窗口的上下坐标
If (((CurrentTop + CelHeight) >= Form1.ScaleHeight - 22 * CelHeight) And Down) Or ((CurrentTop <= 0) And Not Down) Then
Down = Not Down
End If
'计算蝴蝶的Y坐标
If Down Then
border = Form1.ScaleHeight - CelHeight
CurrentTop = MinSingle(CurrentTop + 6, border)
Else
CurrentTop = MaxSingle(CurrentTop - 6, 0)
End If
form1_Paint '调用Paint事件更新动画的显示
End Sub
