VB如何将图像的某个颜色比如白色变透明

[Carlven2012]

如题，
比如这张bmp图像，我想把它BitBlt到Picture1上的图像上，要求它四周的白色显示为秀明，该怎么做？
以前好像记得用过什么vbInvert、vbSrcCopy之类的参数做过。

[of123]

笨办法：获取被它遮挡的背景图片。逐点分析前景像素，凡是白色，设置成背景对应点的像素即可。 需要考虑的两点是： 1 什么是“白色”。渐近色算不算？ 2 你的前景图片，白色部分可能也不是一刀切的。你认为的“真正”前景，可能也有白色的点。如果要排除这些点，算法要复杂一些。当然了，如果你限定透明区在四周的范围，可以稍稍简单一点。

[熊孩子开学喽]

transparentblt

[Tiger_Zhao]

先将 Create a mask image (all black for the transparent colour otherwise white) from a bitmap 中的函数放入模块。

'在窗体上放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

[Tiger_Zhao]

[Carlven2012]

引用 4 楼 Tiger_Zhao 的回复:

谢谢，可惜进不了你那网站，我自己写了一个CreateMaskImage函数，感觉最后那个颜色参数纯粹多余，代码如下，请指教：

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

[Carlven2012]

[Carlven2012]

引用 3 楼 Tiger_Zhao 的回复:

先将 Create a mask image (all black for the transparent colour otherwise white) from a bitmap 中的函数放入模块。

请给出完整的CreateMaskImage函数吧，哥子。谢了。 我那函数遇到其他颜色就不起作用了。

[赵4老师]

还不如用PS删除白色部分，另存为.png格式呢。

[Carlven2012]

哎呀，算了，打算放弃这个方法了，还是用2楼说的那个API函数， 感觉开销要小些、效率也应该要来得快些吧。

[Tiger_Zhao]

' 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 

又：基本功该掌握啊。
用 ip.cn 等工具网站查得 www.vbaccelerator.com 的 ip 为 74.125.136.121，然后向 hosts 文件中加一行

74.125.136.121  www.vbaccelerator.com

[Carlven2012]

引用 9 楼 Tiger_Zhao 的回复:

又：基本功该掌握啊。
用 ip.cn 等工具网站查得 www.vbaccelerator.com 的 ip 为 74.125.136.121，然后向 hosts 文件中加一行

74.125.136.121  www.vbaccelerator.com

是的，我都是在自己摸索，没有系统的学习过。 不过我试过了，你给的代码，还是不行啊。我分别试了让红色、绿色、蓝色、白色、黑色设置透明，结果都是一个格调：白色变透明了？ 怎么办呢？

[Tiger_Zhao]

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

[Carlven2012]

谢谢，我仔细研究了一下，发现可以不用picture3这个控件也能完成。就等于是一个源、一个MASK、一个目标即可。那个创建MASK的函数没变，我只在里面加了一句：picFrom.BackColor=lTransparentColor，然后实现语句如下：

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

[Carlven2012]

[Tiger_Zhao]

你如果不需要保留源图，当然可以在上面直接切割。

[ws1207340832]

引用 7 楼 zhao4zhong1 的回复:

还不如用PS删除白色部分，另存为.png格式呢。

我来说一下，VB根本不支持PNG，你用PS把图片做成png又有何用

[赵4老师]

VB6可以调用GDI+读写显示PNG啊。