圖片的平滑切換處理技術(shù)

--------------------------------------------------------------------------------

　　用過(guò)Anfy Java程序的用戶(hù)一定不會(huì)忘記其優(yōu)秀的圖像效果處理技術(shù)：DUMP、DEFORM、FIREWORKS、SNOW、HUEROT、LAKE、LENS、ROT、WARP、WATER等等,的確讓人興奮不已。(若讀者還不曾用過(guò)Anfy,可以到其相關(guān)網(wǎng)頁(yè)http://www.AnfyTeam.com上去下載,約2917KB,V1.4.3)。但作為愛(ài)好編程的"程序員",老用別人的東西,總覺(jué)得心得不舒服,因此筆者也用VB6.0設(shè)計(jì)了出圖片平滑過(guò)渡、加下雪效果這兩種方法,以饗讀者,而且可以將其設(shè)計(jì)成ActiveX,在您的網(wǎng)頁(yè)中也可以使用--有時(shí)候，看著自己親手做的東西，不管是否完美，總覺(jué)得有種自豪的感覺(jué)--也許這就叫做"自我陶醉"。

　　為了高效處理圖形,當(dāng)然需要用到WIN32 API,以下為常量定義及申明(用戶(hù)可以利用VB6.0中API瀏覽器插入),我們將其存入模塊API.bas中：

Attribute VB_Name = "API模塊"
Const MILLICMETERCELL = 26.45836 '每一個(gè)像素點(diǎn)相當(dāng)于多少微米
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
以下還將定義幾個(gè)常用到的函數(shù)：

'返回兩者中較小的一個(gè)
Public Function Min(ByVal a As Integer, ByVal b As Integer) As Integer
Min = IIf(a > b, b, a)
End Function

'返回兩者中較大的一個(gè)
Public Function Max(ByVal a As Integer, ByVal b As Integer) As Integer
Max = IIf(a > b, a, b)
End Function

以下三個(gè)函數(shù)獲取色彩中的各分量值
'取色彩中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中,函數(shù)Len(s)將返回中字符的個(gè)數(shù)(一個(gè)漢字也是被定義為一個(gè)字符長(zhǎng)度),而在WIN32 API TextOut()要求字符串長(zhǎng)度將一個(gè)漢字定義為2個(gè)字符,因此需要全新的計(jì)算長(zhǎng)度串函數(shù)
'取字符串中有多少個(gè)字符(1個(gè)漢字定義為2個(gè)字符寬度)

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 ‘若為漢字,字符個(gè)數(shù)加1
Next i
Strlen = n
End Function
　　以下兩個(gè)函數(shù)返回用戶(hù)用LoadPicture(PictureFileName)函數(shù)裝入的圖片的高、寬度(以像素為單位),原始的用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
　　用過(guò)Photoshop 5.0的用戶(hù),一定不會(huì)忘記Trient工具,它可將一種色彩平滑過(guò)渡到另一種色彩。以下這個(gè)函數(shù)可以幫我們完成這個(gè)任務(wù)。

'獲取漸變色彩值
'入口參數(shù)：SrcColor 原色彩
' Steps 步驟數(shù)
' CurStep 當(dāng)前的步子
' DstColor 目標(biāo)色彩
'返回值：當(dāng)前的色彩值
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

　　以下兩個(gè)函數(shù)返回用戶(hù)用LoadPicture(PictureFileName)函數(shù)裝入的圖片的高、寬度(以像素為單位),原始的用MILLICMETER為單位。

　　以上的常見(jiàn)函數(shù),用戶(hù)也應(yīng)該將其添加到API.bas中。

一、實(shí)現(xiàn)方法

　　為了從一個(gè)圖片P1平滑向另一個(gè)圖片P2過(guò)渡,如下圖(從右到左將一紅花的圖片過(guò)渡到雪景的圖片)：



　　若用戶(hù)仔細(xì)觀察,您會(huì)發(fā)現(xiàn),其實(shí)可以將過(guò)渡的畫(huà)面分為三個(gè)部分：原始圖片P1部分、過(guò)渡效果部分和目標(biāo)圖片P2部分。對(duì)于原始部分和目標(biāo)部分,我們可以利用Bitblt()直接SRCCOPY過(guò)去即可,因此重要的即是得處理過(guò)渡部分。

　　在上述的API.bas文件中，我們知道GetTrientColor，可以幫我們完成從一種色彩漸進(jìn)到另一種色彩。我們?cè)O(shè)過(guò)渡部分的寬度為tw, 當(dāng)前顯示區(qū)域的高為h,顯示的橫坐標(biāo)為x,那么從右到左過(guò)渡,即是從目標(biāo)色彩漸進(jìn)到原始的色彩,換句話說(shuō)：在色彩成分中,目標(biāo)色由100%逐減到0%,而原始色彩則有0%逐增到100%,其處理方法如下：

　　for i=0 to tw
　　　xx=x+i '當(dāng)前顯示的橫坐標(biāo)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) '取當(dāng)前從p1Color平滑過(guò)渡到p2Color當(dāng)前的漸進(jìn)色
　　　　SetPixel(目標(biāo)DC,xx,j,CurColor)
　　　Next j
　　Next i
　　以上只是處理一個(gè)片斷部分,若需要處理整個(gè)平滑過(guò)渡效果,還需要加入一個(gè)外循環(huán)。另外,為了能高效處理從p1到p2的過(guò)渡過(guò)程,需要將圖片加入到內(nèi)容兼容的DC中

　　dim p1 ,p2 as Picture
　　p1=LoadPicture(P1FileName) '裝入圖片1
　　p2=LoadPicture(p2)'裝入圖片2
　　p1Dc=CreateCompatibleDC(目標(biāo)DC) '建立一個(gè)如目標(biāo)dc兼容的dc
　　SelectObject(p1Dc,p1) '將圖片1選入其中
　　P2Dc=CreateCompatibleDC(目標(biāo)DC)
　　SelectObject(p2Dc,p2)
　　以下程序PictureTranstion.bas可完成①整個(gè)圖片平滑過(guò)渡到另一個(gè)圖片②從左到右③從右到左④從上到下⑤從下到上等五種處理過(guò)程,用戶(hù)還可以根據(jù)以上原理加入其它處理方式,如由小圓逐漸擴(kuò)展到大圓,從左右同時(shí)到中央等等。由于本程序采用取點(diǎn)畫(huà)點(diǎn)處理方法,處理的速度會(huì)因?yàn)槠交�過(guò)渡圖片部分的寬度或高度(若是整個(gè)圖片的過(guò)渡,此時(shí)表示過(guò)渡的幀數(shù))的增加而變得非常慢,但此時(shí)的處理效果最好,當(dāng)然若設(shè)置成非常小,即是一般的從左到右或其它類(lèi)型的轉(zhuǎn)換處理方法。因此在實(shí)際的處理中,還應(yīng)該充許用戶(hù)中斷,最好的辦法是的在處理的循環(huán)中加入DoEvents,而在函數(shù)傳遞入口處加入一個(gè)用地址傳送(VB默認(rèn)的一種方式)的變量IsExit(表示是否中斷),用戶(hù)調(diào)用時(shí),可以用一個(gè)變量傳遞,需要中斷時(shí),可以將其變量設(shè)置成真。(當(dāng)然,應(yīng)該在編程中防止二次調(diào)用)

Attribute VB_Name = "Module2"
'定義效果類(lèi)型
'整個(gè)圖片從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沒(méi)有找到或者不是圖片文件
Public Const TransP2NotFound = -2 '圖片1沒(méi)有找到或者不是圖片文件
Public Const TransUserBreak = -3 '用戶(hù)中斷
'下列程序完成從一幅圖片轉(zhuǎn)化到另一幅圖片的過(guò)程
'入口參數(shù): srcPictureFileName 原圖片文件名
'dstPictureFileName 轉(zhuǎn)換后的目標(biāo)文件名
'w,h 目標(biāo)設(shè)備的高,寬(以像素為單位)
'dstDc 目標(biāo)設(shè)備DC
'Speed 轉(zhuǎn)化速度(值越大效果越好,但速度最慢)
'IsExit 表示是否中斷,請(qǐng)用變量傳遞
'例：Call P1ToP2(,....IsExit)
' 若要求中斷,可以在另外的動(dòng)作中要求IsExit=true
'ShowType 效果類(lèi)型(見(jiàn)TransEnum說(shuō)明)
'返回值：見(jiàn)TransError說(shuō)明

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 '進(jìn)入時(shí),不中斷
On Error Resume Next
Set p1 = LoadPicture(srcPictureFileName) '裝入圖片1
If Err Then
P1ToP2 = TransP1NotFound
Exit Function '若出錯(cuò),則退出
End If
Set p2 = LoadPicture(dstPictureFileName)
If Err Then '裝入圖片2,若出錯(cuò),則刪除裝入的圖片1,然后退出
Set p1 = Nothing
P1ToP2 = TransP2NotFound
Exit Function
End If
h1Dc = CreateCompatibleDC(dstDc) '建立一個(gè)和目標(biāo)上下文環(huán)境兼容的DC
Call SelectObject(h1Dc, p1) '將圖片1選入中
h2Dc = CreateCompatibleDC(dstDc) '建立一個(gè)和目標(biāo)上下文環(huán)境兼容的DC
Call SelectObject(h2Dc, p2) '將圖片2選入中
hMemDC = CreateCompatibleDC(dstDc) '建立一個(gè)兼容的內(nèi)存位圖
hMemPic = CreateCompatibleBitmap(dstDc, w, h)
Call SelectObject(hMemDC, hMemPic) '選入設(shè)備中
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從左到右淡入
'入口參數(shù)：h1DC 原圖片DC
' h2DC目標(biāo)圖片DC
' DscDC 目標(biāo)DC
' hMemDC 緩存DC
' w 目標(biāo)上下文的寬度
' h 目標(biāo)上下文的高度
' TransType 過(guò)渡類(lèi)型
' Speed 光帶長(zhǎng)度(或者過(guò)渡的幀數(shù))
' 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到結(jié)束
　　If xx > 0 Then '若左邊已經(jīng)有圖2出來(lái)
　　　　Call BitBlt(hMemDC, 0, 0, xx, h, h2Dc, 0, 0, SRCCOPY)
　　　　 '則COPY圖2的一部分
　　End If
　　If xx + Speed < w Then '圖1還沒(méi)有完全消失,則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 xNext xx

Case 2 'FromRightToLeft:
　For xx = w To -Speed + 1 Step -1 '光條從-Speed到結(jié)束
　If xx > 0 Then '若左邊已經(jīng)有圖2出來(lái)
　　Call BitBlt(hMemDC, 0, 0, xx, h, h1Dc, 0, 0, SRCCOPY) '則COPY圖2的一部分
　End If
　If xx + Speed < w Then '圖1還沒(méi)有完全消失,則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 '當(dāng)前的坐標(biāo)在可視范圍內(nèi)
　　　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)
　'將當(dāng)前變化的結(jié)果寫(xiě)入目標(biāo)設(shè)備中
　Next xx
Case 3 'FromUptodown:
　For yy = -Speed + 1 To h '光條從-Speed到結(jié)束
　　If yy > 0 Then '若左邊已經(jīng)有圖2出來(lái)
　　　Call BitBlt(hMemDC, 0, 0, w, yy, h2Dc, 0, 0, SRCCOPY)
　　　 '則COPY圖2的一部分
　　End If
　　If yy + Speed < h Then '圖1還沒(méi)有完全消失,則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 '當(dāng)前的坐標(biāo)在可視范圍內(nèi)
　　　　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)
　　　　　　　　 '將當(dāng)前變化的結(jié)果寫(xiě)入目標(biāo)設(shè)備中
　　Next yy
Case 4 ' FromDownToUp
　　For yy = h - 1 To -Speed + 1 Step -1
　　If yy > 0 Then '若左邊已經(jīng)有圖2出來(lái)
　　　Call BitBlt(hMemDC, 0, 0, w, yy, h1Dc, 0, 0, SRCCOPY)
　　　 '則COPY圖2的一部分
　　End If
　　If yy + Speed < h Then '圖1還沒(méi)有完全消失,則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 '當(dāng)前的坐標(biāo)在可視范圍內(nèi)
　　　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)
　　'將當(dāng)前變化的結(jié)果寫(xiě)入目標(biāo)設(shè)備中
　　Next yy
End Select

exitPictureTransition:
　　If IsExit Then '退出為真
　　　　PictureTransition = TransUserBreak '表示用戶(hù)中斷
　　Else
　　　PictureTransition = TransOK '否則OK
　　End If
End Function
二、測(cè)試程序

　　理論講完了,下面該來(lái)用VB6.0制作這種迷人效果了：

　　1、新建一個(gè)工程,向Form中加入一系列控件,設(shè)置各自的Name和各自的相關(guān)屬性（注意：一定要將將Picture控件中的ScaleMode設(shè)置成3）。筆者設(shè)計(jì)的Form見(jiàn)上圖。

　　2、將下列代碼寫(xiě)入窗體Code中：

Dim IsExit As Boolean
Private Sub AboutButton_Click()‘關(guān)于
　　MsgBox MainForm.Caption & Chr(13) & "date: 2000.2.2.",
vbInformation, "About TransPicture"
End Sub

Private Sub Form_Unload(Cancel As Integer)
　　IsExit = True ‘窗體Uload時(shí),中斷為真
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 光標(biāo)(*.Ico)和圖標(biāo)(*.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 & "]出錯(cuò).", vbOKOnly, "錯(cuò)誤"
　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 "隨機(jī)"
　ShowStyle.AddItem "整個(gè)圖片淡入淡出"
　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
　　代碼寫(xiě)好了,現(xiàn)在您可以按下Play,運(yùn)行您的測(cè)試程序。按下"Add",向PictureList加入幾個(gè)圖片,選中某一個(gè)過(guò)渡效果(或隨機(jī)),再按下"Start"。此時(shí),您只需要來(lái)杯咖啡,靜靜地一旁欣賞,怎么樣,不亞于Anfy吧！

　　若想再您的網(wǎng)頁(yè)中加入這種效果,可以將其設(shè)計(jì)可OCX。下篇將向您介紹另一種加下雪效果的AddSnowCtrol,并且設(shè)計(jì)成ActiveX。

　　以上只是筆者的班門(mén)弄斧,不當(dāng)之處,希望多多指教。另外程序由于采用讀點(diǎn)寫(xiě)點(diǎn)方法處理,速度的確不盡人意,筆者曾試想直接處理DC中的hBitmap信息,但苦于手中沒(méi)有資料,只好罷了。若讀者對(duì)此技術(shù)感興趣,可以給我來(lái)信！(本文發(fā)表于2000年第6期《電腦編程技巧與維護(hù)》)

Word版下載地址：http://www.i0713.net/Download/Prog/Dragon/Doc/PicTrans.doc
源程序下載地址：http://www.i0713.net/Download/Prog/Dragon/Prog/PicTrans.zip