|
'完成一幅图片h1到另一幅图片h2从左到右淡入
'入口参数：h1DC 原图片DC
' h2DC目标图片DC
' DscDC 目标DC
' hMemDC 缓存DC
' w 目标上下文的宽度
' h 目标上下文的高度
' TransType 过渡类型
' Speed 光带长度(或者过渡的帧数)
' IsExit 中断处理变量
Public Function PictureTransition(ByVal h1Dc As Long, ByVal h2Dc As Long, ByVal hMemDC As Long, ByVal dstDc As Long, ByVal w As Long, ByVal h As Long, ByVal Speed As Integer, ByVal TransType As Integer, IsExit As Boolean) As Integer
Dim x, xx, yy, y, i, j, n As Long
Dim srcColor, dstColor, curColor As Long
Select Case TransType
Case 0 ' FromP1toP2:
For n = 0 To Speed
For x = 0 To w - 1
For y = 0 To h - 1
srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
curColor = GetTrienColor(srcColor, dstColor, Speed, n)
Call SetPixel(hMemDC, x, y, curColor)
Next y
DoEvents
If IsExit = True Then GoTo exitPictureTransition
Next x
Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY)
Next n
Case 1 'FromLeftToRight:
For xx = -Speed + 1 To w '光条从-Speed到结束
If xx > 0 Then '若左边已经有图2出来
Call BitBlt(hMemDC, 0, 0, xx, h, h2Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
End If
If xx + Speed < w Then '图1还没有完全消失,则COPY部分图1
Call BitBlt(hMemDC, xx + Speed, 0, w - xx - Speed, h, h1Dc, xx + Speed, 0, SRCCOPY)
End If
For i = 0 To Speed
x = xx + i
If x>=0 And x<w Then '当前的坐标在可视范围内
For y = 0 To h - 1
srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
curColor = GetTrienColor(dstColor, srcColor, Speed, i)
Call SetPixel(hMemDC, x, y, curColor)
Next y
DoEvents
If IsExit = True Then GoTo exitPictureTransition
End If
Next i
Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY) '将当前变化的结果写入目标设备中
Next xx
Case 2 'FromRightToLeft:
For xx = w To -Speed + 1 Step -1 '光条从-Speed到结束
If xx > 0 Then '若左边已经有图2出来
Call BitBlt(hMemDC, 0, 0, xx, h, h1Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
End If
If xx + Speed < w Then '图1还没有完全消失,则COPY部分图1
Call BitBlt(hMemDC, xx + Speed, 0, w - xx - Speed, h, h2Dc, xx + Speed, 0, SRCCOPY)
End If
For i = 0 To Speed
x = xx + i
If x >= 0 And x < w Then '当前的坐标在可视范围内
For y = 0 To h - 1
srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
curColor = GetTrienColor(srcColor, dstColor, Speed, i)
Call SetPixel(hMemDC, x, y, curColor)
Next y
DoEvents
If IsExit = True Then GoTo exitPictureTransition
End If
Next i
Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY)
'将当前变化的结果写入目标设备中
Next xx
Case 3 'FromUptodown:
For yy = -Speed + 1 To h '光条从-Speed到结束
If yy > 0 Then '若左边已经有图2出来
Call BitBlt(hMemDC, 0, 0, w, yy, h2Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
End If
If yy + Speed < h Then '图1还没有完全消失,则COPY部分图1
Call BitBlt(hMemDC, 0, yy + Speed, w, h - yy - Speed, h1Dc, 0, yy + Speed, SRCCOPY)
End If
For i = 0 To Speed
y = yy + i
If y >= 0 And y < h Then '当前的坐标在可视范围内
For x = 0 To w - 1
srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
curColor = GetTrienColor(dstColor, srcColor, Speed, i)
Call SetPixel(hMemDC, x, y, curColor)
Next x
DoEvents
If IsExit = True Then GoTo exitPictureTransition
End If
Next i
Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY)
'将当前变化的结果写入目标设备中
Next yy
Case 4 ' FromDownToUp
For yy = h - 1 To -Speed + 1 Step -1
If yy > 0 Then '若左边已经有图2出来
Call BitBlt(hMemDC, 0, 0, w, yy, h1Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
End If
If yy + Speed < h Then '图1还没有完全消失,则COPY部分图1
Call BitBlt(hMemDC, 0, yy + Speed, w, h - yy - Speed, h2Dc, 0, yy + Speed, SRCCOPY)
End If
For i = 0 To Speed
y = yy + i
If y >= 0 And y < h Then '当前的坐标在可视范围内
For x = 0 To w - 1
srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
curColor = GetTrienColor(srcColor, dstColor, Speed, i)
Call SetPixel(hMemDC, x, y, curColor)
Next x
DoEvents
If IsExit = True Then GoTo exitPictureTransition
End If
Next i
Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY) '将当前变化的结果写入目标设备中
Next yy
End Select
exitPictureTransition:
If IsExit Then '退出为真
PictureTransition = TransUserBreak '表示用户中断
Else
PictureTransition = TransOK '否则OK
End If
End Function
二、测试程序
理论讲完了,下面该来用VB6.0制作这种迷人效果了：
1、新建一个工程,向Form中加入一系列控件,设置各自的Name和各自的相关属性（注意：一定要将将Picture控件中的ScaleMode设置成3）。笔者设计的Form见上图。
2、将下列代码写入窗体Code中：
Dim IsExit As BooleanPrivate Sub AboutButton_Click()‘关于MsgBox MainForm.Caption & Chr(13) & "date: 2000.2.2.", vbInformation, "About TransPicture"
End Sub
Private Sub Form_Unload(Cancel As Integer)
IsExit = True ‘窗体Uload时,中断为真
End Sub
Private Sub RunAndStopButton_Click()
Dim n, i As Integer
i = Picturelist.ListIndex
If RunAndStopButton.Caption = "Start" Then
Randomize
TextSpeed.Enabled = False
UpDown.Enabled = False
ShowStyle.Enabled = False
RunAndStopButton.Caption = "Stop"
Picturelist.Enabled = False
BrowButton.Enabled = False
n = ShowStyle.ListIndex
While 1
If n = 0 Then n = Int(Rnd * 5) + 1
ShowStyle.ListIndex = n
Picturelist.ListIndex = i
If P1ToP2(Picturelist.List(i), Picturelist.List((i + 1) Mod Picturelist.ListCount), Pic.hdc, Pic.ScaleWidth, Pic.ScaleHeight, UpDown.Value, ShowStyle.ListIndex - 1, IsExit) = TransUserBreak Then
GoTo exitwhile
End If
i = i + 1
If i = Picturelist.ListCount Then i = 0
Wend
Else
IsExit = True
End If
exitwhile:
Picturelist.ListIndex = i
RunAndStopButton.Caption = "Start"
Picturelist.Enabled = True
TextSpeed.Enabled = True
UpDown.Enabled = True
ShowStyle.Enabled = True
BrowButton.Enabled = True
End Sub
Private Sub picturelist_Click()
On Error Resume Next
Set Pic.Picture = LoadPicture(Picturelist.List(Picturelist.ListIndex))
End Sub
Private Sub BrowButton_Click()
On Error Resume Next
Dim s, InitDir As String
Dlg.Flags = cdlOFNExplorer '允许多选文件
Dlg.Filter = "所有的图形文件|(*.bmp;*.jpg;*.wfm;*.emf;*.ico;*.rle;*.gif;*.cur)|JPEG文件|*.jpg|BMP文件|(*.bmp)|GIF文件|*.gif|光标(*.Ico)和图标(*.Cur)文件|(*.cur,*.ico)|WMF元文件(*.wmf,*.emf)|(*.wmf,*.emf)|RLE行程文件(*.rle)|*.rle"
Dlg.ShowOpen
If Err Then Exit Sub
Set Pic.Picture = LoadPicture(Dlg.FileName)
If Err Then
MsgBox "装入图片[" & Dlg.FileName & "]出错.", vbOKOnly, "错误"
Else
Picturelist.AddItem Dlg.FileName
Picturelist.ListIndex = Picturelist.ListCount - 1
End If
If ShowStyle.ListIndex >= 0 And Picturelist.ListCount >= 2 Then
RunAndStopButton.Enabled = True
End If
End Sub
Private Sub Form_Load()
ShowStyle.AddItem "随机"
ShowStyle.AddItem "整个图片淡入淡出"
ShowStyle.AddItem "从左到右淡入"
ShowStyle.AddItem "从右到左淡入"
ShowStyle.AddItem "从上到下淡入"
ShowStyle.AddItem "从下到上淡入"
ShowStyle.ListIndex = 0
UpDown.Value = 20
End Sub
Private Sub ShowStyle_click()
If ShowStyle.ListIndex >= 0 And Picturelist.ListCount >= 2 Then
RunAndStopButton.Enabled = True
End If
End Sub
Private Sub TextSpeed_Change()
n = Int(Val(TextSpeed.Text))
If n < UpDown.Min Or n > UpDown.Max Then
n = 20
End If
UpDown.Value = n
TextSpeed.Text = n
End Sub
Private Sub UpDown_Change()
TextSpeed.Text = UpDown.Value
End Sub
代码写好了,现在您可以按下Play,运行您的测试程序。按下“Add”,向PictureList加入几个图片,选中某一个过渡效果(或随机),再按下”Start”。此时,您只需要来杯咖啡,静静地一旁欣赏,怎么样,不亚于Anfy吧！
若想再您的网页中加入这种效果,可以将其设计可OCX。下篇将向您介绍另一种加下雪效果的AddSnowCtrol,并且设计成ActiveX。
以上只是笔者的班门弄斧,不当之处,希望多多指教。另外程序由于采用读点写点方法处理,速度的确不尽人意,笔者曾试想直接处理DC中的hBitmap信息,但苦于手中没有资料,只好罢了。
|
