【CBM666 图片透明淡进溶合共享】

cbm6666 2010-11-23 02:26:58

加精

'仅供对图像处理有兴趣的朋友相互交流

'Picture1是背景图 Picture2是那只背景为蓝色的鸟,Picture3是与Picture2相同尺寸的空图片框再添加 Timer1做淡进用

'Picture3是先将Picture2欲放在Picture1里的区块图当成背景图,再将Picture2屏蔽掉蓝色后的图溶合在Picture3
'最后再将Picture3以淡进的方式显示在Picture1
'如果不考虑要将Picture2屏蔽掉透明色的话,就不需要Picture3了, 直接Picture2与Picture1以淡进方式溶合即可.

'本代码你可以学习到如何截取Picture1里面部份的区块图, 也可学到如何将两张图以不同的透明度来溶合成一张图片

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 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 AlphaBlend Lib "msimg32" (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 widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type rBlendProps
tBlendOp As Byte
tBlendOptions As Byte
tBlendAmount As Byte
tAlphaType As Byte
End Type
Dim NowLevel&, Fadeio%, TransColor&, W&, H&, OldX&, OldY&
Private Sub Form_Load()
Timer1.Enabled = False: TransColor = vbBlue: Picture2.BackColor = TransColor
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
Picture1.BorderStyle = 0: Picture2.BorderStyle = 0: Picture3.BorderStyle = 0
Picture1.AutoRedraw = True: Picture2.AutoRedraw = True: Picture3.AutoRedraw = True
Picture2.Move Screen.Width: Picture3.Move Screen.Width
End Sub

Private Sub Command1_Click()
W = Picture2.Width: H = Picture2.Height
OldX = (Picture1.Width - W) \ 2 \ 15: OldY = (Picture1.Height - H) \ 2 \ 15
BitBlt Picture3.hDC, 0, 0, Picture3.Width \ 15, Picture3.Height \ 15, Picture1.hDC, OldX, OldY, vbSrcCopy '将桌面图象绘制到窗体
GdiTransparentBlt Picture3.hDC, 0, 0, W \ 15, H \ 15, Picture2.hDC, 0, 0, W \ 15, H \ 15, TransColor
NowLevel = 0: Timer1.Enabled = True: Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
NowLevel = IIf(NowLevel + 10 >= 130, 130, NowLevel + 10)
If NowLevel = 130 Then Timer1.Enabled = False
ShowMixerPic Picture3, Picture1, NowLevel
End Sub

Sub ShowMixerPic(cSrc As PictureBox, cDest As PictureBox, ByVal nLevel As Byte)
On Error Resume Next
Dim LrProps As rBlendProps
Dim LnBlendPtr As Long
cDest.Cls
LrProps.tBlendAmount = nLevel
CopyMemory LnBlendPtr, LrProps, 4
With cSrc
AlphaBlend cDest.hDC, OldX, OldY, .ScaleWidth \ 15, .ScaleHeight \ 15, .hDC, 0, 0, .ScaleWidth \ 15, .ScaleHeight \ 15, LnBlendPtr
End With
cDest.Refresh
End Sub