透明位图绘制方法在网上见得很多，多数是采用事先做好一个Mask图，这方法优点是速度快，但就是太麻烦，灵活性差。
任意指定透明色，当然经常也要用到，为此，API提供了一个函数TransparentBlt，可这个函数，非常让人遗憾，VB的API浏览器中不带它是有道理的，因为，它在Win98下有严重内存漏洞，你若有98系统，可试一下：
for i=1 to 20000
TransparentBlt ....
next
同样的图片，在我的XP下16毫秒可完成，但在98下用了14秒，而且，提示系统资源不足，当机了！

下面我写了一个函数就是可以代替TransparentBlt的一种方法，速度当然会慢些，但在任何系统下都可放心使用。

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long) As Long
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 StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Public Function TranBlt(DestHdc As Long, X As Long, y As Long, w As Long, h As Long, srcHdcOrBmp As Long, Optional srcX As Long, Optional srcY As Long, Optional srcW As Long, Optional srcH As Long, Optional tc As Long = -1, Optional IsBmp As Boolean) As Long
    'srcHdcOrBmp参数 传入的可以是hdc也可以是Bmp对象的Handle，
    'IsBmp参数 为真时srcHdcOrBmp代表Bmp对象的Handle，为假时代表hdc
    '返回值 成功时返回透明色，不成功时返回-1
    Dim tHdc(3) As MemHdc
    Dim j As Long, oc As Long, i As Long, Bm As BITMAP, cc As Long, NewDc As Long
    Dim sw As Long, sh As Long, sBmp As Long, sHdc As Long, obm As Long, NewX As Long, NewY As Long
    If DestHdc = 0 Or srcHdcOrBmp = 0 Or w = 1 And h = 1 Then GoTo fail
    If IsBmp Then   '若传入的是Bmp句柄，需为其创建一个临时DC
        sBmp = srcHdcOrBmp
        tHdc(3) = NewMyHdc(DestHdc, 0, 0, srcHdcOrBmp)
        sHdc = tHdc(3).hdc
    Else
        sHdc = srcHdcOrBmp
        If srcW = 0 Then sBmp = GetCurrentObject(sHdc, 7)
    End If
    If sHdc = 0 Or sBmp = 0 Then GoTo fail
    If srcW = 0 Then    '若没有提供源图大小，需取得整个源图大小
        GetObj sBmp, Len(Bm), Bm
        sw = Bm.bmWidth - srcX
        sh = Bm.bmHeight - srcY
    Else
        sw = srcW
        sh = srcH
    End If
    If sw < 1 Or sh < 1 Then GoTo fail
    If tc = -1 Then
        cc = GetPixel(sHdc, srcX, srcY)       '将左上角第一个像素作为源图背景色，用于透明
    Else
        cc = tc
    End If
    If w <> sw Or h <> sh Then
        tHdc(2) = NewMyHdc(DestHdc, w, h)
        StretchBlt tHdc(2).hdc, 0, 0, w, h, sHdc, srcX, srcY, sw, sh, vbSrcCopy
        '先将源图缩放，下面步骤就一样了。
        NewDc = tHdc(2).hdc
    Else
        NewDc = sHdc
        NewX = srcX
        NewY = srcY
    End If
    BitBlt DestHdc, X, y, w, h, NewDc, NewX, NewY, vbSrcInvert
    '将源图先反色（XOR）绘入目标图，若源图背景为黑色，此步可省
       
    '下面是制作Mask图的方法
    i = CreateBitmap(w, h, 1, 1, ByVal 0&)  '建立单色位图
    tHdc(0) = NewMyHdc(DestHdc, 0, 0, i)       '为单色图建立新DC，并选入
    tHdc(1) = NewMyHdc(DestHdc, w, h)          '另建一个彩色图及DC，用于存放Mask图
    oc = SetBkColor(NewDc, cc)              '将源图背景色改为透明色
    BitBlt tHdc(0).hdc, 0, 0, w, h, NewDc, NewX, NewY, vbSrcCopy
    '先将源图绘入单色DC，由此产生只有正反的Mask图，背景色（透明色）为黑，其它为白
    SetBkColor NewDc, oc                    '恢复源图背景色，不是必须的，但这是个好习惯。
    BitBlt tHdc(1).hdc, 0, 0, w, h, tHdc(0).hdc, 0, 0, vbSrcCopy
    '单色DC必须复制进彩色DC才能进行后面的的AND运算
    'Mask图完成，并已放入彩色DC
       
    BitBlt DestHdc, X, y, w, h, tHdc(1).hdc, 0, 0, vbSrcAnd    '标准透明绘图：选将Mask图用And运算绘入，
    BitBlt DestHdc, X, y, w, h, NewDc, NewX, NewY, vbSrcInvert '再将源图以反色(XOR)绘入一次
   
    DelMyHdc tHdc(0)
    DelMyHdc tHdc(1)
   
    If tHdc(2).hdc <> 0 Then DelMyHdc tHdc(2)
    If tHdc(3).hdc <> 0 Then DelMyHdc tHdc(3)
    TranBlt = cc
    Exit Function
fail:
    If tHdc(3).hdc <> 0 Then DelMyHdc tHdc(3)
    TranBlt = -1
End Function

Private Function NewMyHdc(dHdc As Long, w As Long, h As Long, Optional Bm As Long) As MemHdc
    With NewMyHdc
        .hdc = CreateCompatibleDC(dHdc)
        If Bm = 0 Then
            .Bmp = CreateCompatibleBitmap(dHdc, w, h)
        Else
            .Bmp = Bm
        End If
        .obm = SelectObject(.hdc, .Bmp)
    End With
End Function
Private Function DelMyHdc(MyHdc As MemHdc, Optional nobmp As Boolean) As MemHdc
    With MyHdc
        If .hdc <> 0 And .obm <> 0 Then SelectObject .hdc, .obm
        If nobmp = False And .Bmp <> 0 Then DeleteObject .Bmp
        If .hdc <> 0 Then DeleteDC .hdc
    End With
End Function

Private Sub Command1_Click()
    TranBlt Picture1.hdc, 0, 0, Image1.Width, Image1.Height, Image1.Picture.handle, , , , , , True
End Sub

Private Sub Form_Load()
    Me.ScaleMode = 3
End Sub

本篇中的公用函数NewMyHdc、DelMyHdc及相关结构与API声明，可在以下文章中找到
http://blog.csdn.net/homezj/archive/2005/04/14/348001.aspx