809
社区成员
发帖
与我相关
我的任务
分享
Private Sub Command1_Click()
Dim w As Long, h As Long
Picture2.ScaleMode = 3
w = Picture2.ScaleWidth
h = Picture2.ScaleHeight
'得到掩码图。
CreateMaskImage Picture1, Picture2, vbBlue
'将源图反色画在目标图上
BitBlt Picture4.hDC, 0, 0, w, h, Picture1.hDC, 0, 0, vbSrcInvert
'在目标图上:画掩码图
BitBlt Picture4.hDC, 0, 0, w, h, Picture2.hDC, 0, 0, vbSrcAnd
'在目标图上:画源图
BitBlt Picture4.hDC, 0, 0, w, h, Picture1.hDC, 0, 0, vbSrcInvert
'刷新
Picture4.Refresh
End Sub
Option Explicit
Private Sub Command1_Click()
CreateMaskImage Picture1, Picture2, vbRed '透明色'
MsgBox "得到掩码图。"
'修正这这一段'
Picture3.PaintPicture Picture2.Image, 0, 0, , , , , , , vbNotSrcCopy
Picture3.PaintPicture Picture1.Image, 0, 0, , , , , , , vbSrcAnd
MsgBox "切割出非透明部分。"
Picture4.PaintPicture Picture2.Image, 0, 0, , , , , , , vbSrcAnd
MsgBox "用 AND 模式挖空。"
Picture4.PaintPicture Picture3.Image, 0, 0, , , , , , , vbSrcPaint
MsgBox "用 OR 模式合并。"
End Sub
Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.BackColor = vbRed '要和透明色一致'
Picture2.AutoRedraw = True
Picture2.BackColor = vbWhite
Picture3.AutoRedraw = True
Picture4.AutoRedraw = True
Dim pic As IPictureDisp
'透明图
Set pic = LoadPicture(App.Path & "\1411962394_681908.bmp") '还是bmp格式最好,用其他压缩格式颜色会变化'
Picture1.PaintPicture pic, 0, 0
'目标背景图
Set pic = LoadPicture("C:\WINDOWS\Web\Wallpaper\Bliss.bmp")
Picture4.PaintPicture pic, -6000, 0
End Sub
' Creates a memory DC
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hDC As Long _
) As Long
' Creates a bitmap in memory:
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal nWidth As Long, ByVal nHeight As Long _
) As Long
' Places a GDI Object into DC, returning the previous one:
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, ByVal hObject As Long _
) As Long
' Deletes a GDI Object:
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long _
) As Long
' Copies Bitmaps from one DC to another, can also perform
' raster operations during the transfer:
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 Const SRCCOPY = &HCC0020
' Sets the backcolour of a device context:
Private Declare Function SetBkColor Lib "gdi32" _
(ByVal hDC As Long, ByVal crColor As Long) As Long
Public Function CreateMaskImage( _
ByRef picFrom As PictureBox, _
ByRef picTo As PictureBox, _
Optional ByVal lTransparentColor As Long = -1 _
) As Boolean
Dim lhDC As Long
Dim lhBmp As Long
Dim lhBmpOld As Long
' Make picTo the same size as picFrom and clear it:
With picTo
.Width = picFrom.Width
.Height = picFrom.Height
.Cls
End With
' Create a monochrome DC & Bitmap of the
' same size as the source picture:
lhDC = CreateCompatibleDC(0)
If (lhDC <> 0) Then
lhBmp = CreateCompatibleBitmap(lhDC, _
picFrom.ScaleWidth \ Screen.TwipsPerPixelX, _
picFrom.ScaleHeight \ Screen.TwipsPerPixelY)
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
' Set the back 'colour' of the monochrome
' DC to the colour we wish to be transparent:
If (lTransparentColor = -1) Then lTransparentColor = picFrom.BackColor
SetBkColor lhDC, lTransparentColor
' Copy from the from picture to the monochrome DC
' to create the mask:
BitBlt lhDC, 0, 0, _
picFrom.ScaleWidth \ Screen.TwipsPerPixelX,
picFrom.ScaleHeight \ Screen.TwipsPerPixelY, _
picFrom.hDC, 0, 0, SRCCOPY
' Now put the mask into picTo:
BitBlt picTo.hDC, 0, 0, _
picFrom.ScaleWidth \ Screen.TwipsPerPixelX, _
picFrom.ScaleHeight \ Screen.TwipsPerPixelY, _
lhDC, 0, 0, SRCCOPY
picTo.Refresh
' Clear up the bitmap we used to create
' the mask:
SelectObject lhDC, lhBmpOld
DeleteObject lhBmp
End If
' Clear up the monochrome DC:
DeleteObject lhDC
End If
End Function
74.125.136.121 www.vbaccelerator.com
Public Sub CreateMaskImage(imgFrom As PictureBox, imgTo As PictureBox, color As Long)
Dim w As Long, h As Long, imgHDC As Long
Dim hBmp As Long, hDC As Long, hDib As Long, oc As Long
imgHDC = imgTo.hDC
w = imgTo.Width / 15
h = imgTo.Height / 15
Debug.Print w, h
hBmp = CreateBitmap(w, h, 1, 1, ByVal 0&) '建立单色位图
hDC = CreateCompatibleDC(imgHDC) '为单色图建立新DC,并选入
hDib = SelectObject(hDC, hBmp)
'oc = SetBkColor(hDC, color) 'SetBkColor这两句不要,完全也能实现想要的透明白色的效果,不知为何?
BitBlt hDC, 0, 0, w, h, imgFrom.hDC, 0, 0, vbSrcCopy '将图像绘入
'SetBkColor hDC, oc
BitBlt imgHDC, 0, 0, w, h, hDC, 0, 0, vbSrcCopy '再将该单色图像显示出来
SelectObject hDC, hDib '释放资源
DeleteObject hBmp
DeleteDC hDC
End Sub
'在窗体上放4个PictureBox,1个CommandButton'
Option Explicit
Private Sub Command1_Click()
CreateMaskImage Picture1, Picture2, vbWhite
MsgBox "得到掩码图。"
Picture3.PaintPicture Picture1.Image, 0, 0
Picture3.PaintPicture Picture2.Image, 0, 0, , , , , , , vbSrcInvert
MsgBox "切割出非透明部分。"
Picture4.PaintPicture Picture2.Image, 0, 0, , , , , , , vbSrcAnd
MsgBox "用 AND 模式挖空。"
Picture4.PaintPicture Picture3.Image, 0, 0, , , , , , , vbSrcPaint
MsgBox "用 OR 模式合并。"
End Sub
Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.BackColor = vbWhite
Picture2.AutoRedraw = True
Picture2.BackColor = vbWhite
Picture3.AutoRedraw = True
Picture4.AutoRedraw = True
Dim pic As IPictureDisp
'透明图
Set pic = LoadPicture(App.Path & "\1411556040_985560.jpg")
Picture1.PaintPicture pic, 0, 0
'目标背景图
Set pic = LoadPicture("C:\WINDOWS\Web\Wallpaper\Bliss.bmp")
Picture4.PaintPicture pic, 0, 0
End Sub