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

Question

vb透明色

Answer 1

先将 Create a mask image (all black for the transparent colour otherwise white) from a bitmap 中的函数放入模块。
'在窗体上放4个PictureBox，1个CommandButton'
Option ExplicitPrivate 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

Answer 2

谢谢，可惜进不了你那网站，我自己写了一个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

Answer 3

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

Answer 4

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

Answer 5

' 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

Answer 6

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

Answer 7

Option ExplicitPrivate 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 SubPrivate 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

Answer 8

谢谢，我仔细研究了一下，发现可以不用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