图片的平滑切换处理技术
--------------------------------------------------------------------------------
用过Anfy Java程序的用户一定不会忘记其优秀的图像效果处理技术：DUMP、DEFORM、FIREWORKS、SNOW、HUEROT、LAKE、LENS、ROT、WARP、WATER等等,的确让人兴奋不已。(若读者还不曾用过Anfy,可以到其相关网页http://www.AnfyTeam.com上去下载,约2917KB,V1.4.3)。但作为爱好编程的"程序员",老用别人的东西,总觉得心得不舒服,因此笔者也用VB6.0设计了出图片平滑过渡、加下雪效果这两种方法,以飨读者,而且可以将其设计成ActiveX,在您的网页中也可以使用--有时候，看着自己亲手做的东西，不管是否完美，总觉得有种自豪的感觉--也许这就叫做"自我陶醉"。
为了高效处理图形,当然需要用到WIN32 API,以下为常量定义及申明(用户可以利用VB6.0中API浏览器插入),我们将其存入模块API.bas中：
Attribute VB_Name = "API模块"
Const MILLICMETERCELL = 26.45836 '每一个像素点相当于多少微米
Public Const BLACKNESS = &H42
Public Const WHITENESS = &HFF0062
Public Const DSTINVERT = &H550009
Public Const NOTSRCCOPY = &H330008
Public Const NOTSRCERASE = &H1100A6
Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCINVERT = &H660046
Public Const SRCPAINT = &HEE0086
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (
ByVal hdc As Long, ByVal x As Long, ByVal y As Long,
ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (
ByVal hdc As Long, ByVal hObject As Long) As Long
Public 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
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long,
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long,
ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long,
ByVal dwRop As Long) As Long
Public Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT,
ByVal HBrush As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Public Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long,
ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Public Declare Function GetPaletteEntries Lib "gdi32" (
ByVal hPalette As Long, ByVal wStartIndex As Long,
ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Public Declare Function GetBitmapDimensionEx Lib "gdi32" (
ByVal hBitmap As Long, lpDimension As Size) As Long
Public Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
以下还将定义几个常用到的函数：
'返回两者中较小的一个
Public Function Min(ByVal a As Integer, ByVal b As Integer) As Integer
Min = IIf(a > b, b, a)
End Function
'返回两者中较大的一个
Public Function Max(ByVal a As Integer, ByVal b As Integer) As Integer
Max = IIf(a > b, a, b)
End Function
以下三个函数获取色彩中的各分量值
'取色彩中n的Red的值
Public Function GetRed(ByVal n As Long) As Integer
GetRed = n Mod 256&
End Function
'取色彩n中的Green的值
Public Function GetGreen(ByVal n As Long) As Integer
GetGreen = (n \ 256&) Mod 256&
End Function
'取色彩n中的Blue的值
Public Function GetBlue(ByVal n As Long) As Integer
GetBlue = n \ 65536
End Function
在VB6.0中,函数Len(s)将返回中字符的个数(一个汉字也是被定义为一个字符长度),而在WIN32 API TextOut()要求字符串长度将一个汉字定义为2个字符,因此需要全新的计算长度串函数
'取字符串中有多少个字符(1个汉字定义为2个字符宽度)
Public Function Strlen(ByVal s As String) As Integer
Dim i As Integer
n = Len(s)
For i = 1 To n
If Asc(Mid$(s, i, 1)) < 0 Then n = n + 1 ‘若为汉字,字符个数加1
Next i
Strlen = n
End Function
以下两个函数返回用户用LoadPicture(PictureFileName)函数装入的图片的高、宽度(以像素为单位),原始的用MILLICMETER为单位。
'获取位图的宽度(以像素为单位)
Public Function GetPictureWidth(ByVal p As Picture) As Integer
GetPictureWidth = Int(p.Width / MILLICMETERCELL + 0.5)
End Function
'获取位图的高度(以像素为单位)
Public Function GetPictureHeight(ByVal p As Picture) As Integer
GetPictureHeight = Int(p.Height / MILLICMETERCELL + 0.5)
End Function
用过Photoshop 5.0的用户,一定不会忘记Trient工具,它可将一种色彩平滑过渡到另一种色彩。以下这个函数可以帮我们完成这个任务。
'获取渐变色彩值
'入口参数：SrcColor 原色彩
' Steps 步骤数
' CurStep 当前的步子
' DstColor 目标色彩
'返回值：当前的色彩值
Public Function GetTrienColor(ByVal scrColor As Long,
ByVal dstColor As Long, ByVal Steps As Integer,
ByVal curStep As Integer) As Long
Dim sR, sG, sB, dR, dG, dB As Integer
sR = GetRed(scrColor)
sG = GetGreen(scrColor)
sB = GetBlue(scrColor)
dR = GetRed(dstColor)
dG = GetGreen(dstColor)
dB = GetBlue(dstColor)
sR = sR + curStep * (dR - sR) / Steps
sG = sG + curStep * (dG - sG) / Steps
sB = sB + curStep * (dB - sB) / Steps
GetTrienColor = RGB(sR, sG, sB)
End Function
以下两个函数返回用户用LoadPicture(PictureFileName)函数装入的图片的高、宽度(以像素为单位),原始的用MILLICMETER为单位。
以上的常见函数,用户也应该将其添加到API.bas中。
一、实现方法
为了从一个图片P1平滑向另一个图片P2过渡,如下图(从右到左将一红花的图片过渡到雪景的图片)：
若用户仔细观察,您会发现,其实可以将过渡的画面分为三个部分：原始图片P1部分、过渡效果部分和目标图片P2部分。对于原始部分和目标部分,我们可以利用Bitblt()直接SRCCOPY过去即可,因此重要的即是得处理过渡部分。
在上述的API.bas文件中，我们知道GetTrientColor，可以帮我们完成从一种色彩渐进到另一种色彩。我们设过渡部分的宽度为tw, 当前显示区域的高为h,显示的横坐标为x,那么从右到左过渡,即是从目标色彩渐进到原始的色彩,换句话说：在色彩成分中,目标色由100%逐减到0%,而原始色彩则有0%逐增到100%,其处理方法如下：
for i=0 to tw
xx=x+i '当前显示的横坐标X
for j=0 to h-1
p1Color=GetPixel(p1,xx,j) '取图片1的原始色彩
p2=Color=GetPixel(p2,xx,j)'取图片2的原始色彩
CurColor=GetTreintColor(p1color,p2Color,tw,i) '取当前从p1Color平滑过渡到p2Color当前的渐进色
SetPixel(目标DC,xx,j,CurColor)
Next j
Next i
以上只是处理一个片断部分,若需要处理整个平滑过渡效果,还需要加入一个外循环。另外,为了能高效处理从p1到p2的过渡过程,需要将图片加入到内容兼容的DC中
dim p1 ,p2 as Picture
p1=LoadPicture(P1FileName) '装入图片1
p2=LoadPicture(p2)'装入图片2
p1Dc=CreateCompatibleDC(目标DC) '建立一个如目标dc兼容的dc
SelectObject(p1Dc,p1) '将图片1选入其中
P2Dc=CreateCompatibleDC(目标DC)
SelectObject(p2Dc,p2)
以下程序PictureTranstion.bas可完成①整个图片平滑过渡到另一个图片②从左到右③从右到左④从上到下⑤从下到上等五种处理过程,用户还可以根据以上原理加入其它处理方式,如由小圆逐渐扩展到大圆,从左右同时到中央等等。由于本程序采用取点画点处理方法,处理的速度会因为平滑过渡图片部分的宽度或高度(若是整个图片的过渡,此时表示过渡的帧数)的增加而变得非常慢,但此时的处理效果最好,当然若设置成非常小,即是一般的从左到右或其它类型的转换处理方法。因此在实际的处理中,还应该充许用户中断,最好的办法是的在处理的循环中加入DoEvents,而在函数传递入口处加入一个用地址传送(VB默认的一种方式)的变量IsExit(表示是否中断),用户调用时,可以用一个变量传递,需要中断时,可以将其变量设置成真。(当然,应该在编程中防止二次调用)
Attribute VB_Name = "Module2"
'定义效果类型
'整个图片从1幅到另一幅
Public Const FromP1toP2 = 0
Public Const FromLeftToRight = 1 '从左到右
Public Const FromRightToLeft = 2 '从右到左
Public Const FromUpToDwon = 3 '从上到下
Public Const FromDownToUp = 4 '从下到上
'效果返回定义
Public Const TransOK = 0 '正常
Public Const TransP1NotFound = -1 '图片1没有找到或者不是图片文件
Public Const TransP2NotFound = -2 '图片1没有找到或者不是图片文件
Public Const TransUserBreak = -3 '用户中断
'下列程序完成从一幅图片转化到另一幅图片的过程
'入口参数: srcPictureFileName 原图片文件名
'dstPictureFileName 转换后的目标文件名
'w,h 目标设备的高,宽(以像素为单位)
'dstDc 目标设备DC
'Speed 转化速度(值越大效果越好,但速度最慢)
'IsExit 表示是否中断,请用变量传递
'例：Call P1ToP2(,....IsExit)
' 若要求中断,可以在另外的动作中要求IsExit=true
'ShowType 效果类型(见TransEnum说明)
'返回值：见TransError说明
Public Function P1ToP2(
ByVal srcPictureFileName As String,
ByVal dstPictureFileName As String, ByVal dstDc As Long,
w As Long, h As Long, ByVal Speed As Integer,
ByVal ShowType As Integer, IsExit As Boolean) As Integer
Dim h1Dc, h2Dc, hMemDC, hMemPic As Long
Dim p1, p2 As Picture
Dim Result As integer
IsExit = False '进入时,不中断
On Error Resume Next
Set p1 = LoadPicture(srcPictureFileName) '装入图片1
If Err Then
P1ToP2 = TransP1NotFound
Exit Function '若出错,则退出
End If
Set p2 = LoadPicture(dstPictureFileName)
If Err Then '装入图片2,若出错,则删除装入的图片1,然后退出
Set p1 = Nothing
P1ToP2 = TransP2NotFound
Exit Function
End If
h1Dc = CreateCompatibleDC(dstDc) '建立一个和目标上下文环境兼容的DC
Call SelectObject(h1Dc, p1) '将图片1选入中
h2Dc = CreateCompatibleDC(dstDc) '建立一个和目标上下文环境兼容的DC
Call SelectObject(h2Dc, p2) '将图片2选入中
hMemDC = CreateCompatibleDC(dstDc) '建立一个兼容的内存位图
hMemPic = CreateCompatibleBitmap(dstDc, w, h)
Call SelectObject(hMemDC, hMemPic) '选入设备中
Result = PictureTransition(h1Dc, h2Dc, hMemDC,
dstDc, w, h, Speed, ShowType, IsExit)
Set p1 = Nothing
Set p2 = Nothing
Call DeleteDC(h1Dc)
Call DeleteDC(h2Dc)
Call DeleteDC(hMemDC)
Call DeleteObject(hMemPic)
P1ToP2 = Result
End Function
'完成一幅图片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
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 Boolean
Private 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信息,但苦于手中没有资料,只好罢了。若读者对此技术感兴趣,可以给我来信！(本文发表于2000年第6期《电脑编程技巧与维护》)
Word版下载地址：http://www.i0713.net/Download/Prog/Dragon/Doc/PicTrans.doc
源程序下载地址：http://www.i0713.net/Download/Prog/Dragon/Prog/PicTrans.zip
