★★源码放松★★ 经典：让窗体的白色部分透明，这个可不一般。

Option Explicit
     
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 TypePrivate Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Sub MakeTransparent(frm As Form, pic As PictureBox)
Const RGN_OR = 2Dim border_width As Single
Dim title_height As Single
Dim bm As BITMAP
Dim bytes() As Byte
Dim ints() As Integer
Dim longs() As Long
Dim R As Integer
Dim C As Integer
Dim start_c As Integer
Dim stop_c As Integer
Dim x0 As Long
Dim y0 As Long
Dim combined_rgn As Long
Dim new_rgn As Long
Dim offset As Integer
Dim colourDepth As Integer    frm.ScaleMode = vbPixels
    
    pic.ScaleMode = vbPixels
    pic.AutoRedraw = True
    pic.Picture = pic.Image
    
    ' 获取窗体的边框大小
    border_width = (frm.ScaleX(frm.Width, vbTwips, vbPixels) - frm.ScaleWidth) / 2
    title_height = frm.ScaleX(frm.Height, vbTwips, vbPixels) - border_width - frm.ScaleHeight
    
    ' 获取图片大小
    x0 = pic.Left + border_width
    y0 = pic.Top + title_height
    
    '给出图片信息
    GetObject pic.Image, Len(bm), bm
    Select Case bm.bmBitsPixel
    Case 15, 16:
    'MsgBox _
    "图片框中图片的颜色大高。",vbExclamation + vbOKOnly
    
    colourDepth = 2
    
    ' 分配空格给图片.
    ReDim ints(0 To bm.bmWidthBytes \ 2 - 1, 0 To bm.bmHeight - 1)
    ' 给出图片表面数据
    GetBitmapBits pic.Image, bm.bmHeight * bm.bmWidthBytes, ints(0, 0)
    
    ' 建立表单区域
    For R = 0 To bm.bmHeight - 2
    
    C = 0
    Do While C < bm.bmWidth
    start_c = 0
    stop_c = 0
    
    ' 查找白色区域,屏蔽
    Do While C < bm.bmWidth
    If (ints(C, R) And &H7FFF) <> &H7FFF Then Exit Do
        C = C + 1
    Loop
    start_c = C
    
    Do While C < bm.bmWidth
    If (ints(C, R) And &H7FFF) = &H7FFF Then Exit Do
        C = C + 1
    Loop
    stop_c = C
    
    If start_c < bm.bmWidth Then
    If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1
    
    new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)
    
    If combined_rgn = 0 Then
    combined_rgn = new_rgn
    Else
    CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
    DeleteObject new_rgn
    End If
    End If
    Loop
    Next R
    
    Case 24:
    colourDepth = 3
    
    ReDim bytes(0 To bm.bmWidthBytes - 1, 0 To bm.bmHeight - 1)
    
    GetBitmapBits pic.Image, bm.bmHeight * bm.bmWidthBytes, bytes(0, 0)
    
    For R = 0 To bm.bmHeight - 2
    ' Create a region for this row.
    C = 0
    Do While C < bm.bmWidth
    start_c = 0
    stop_c = 0
    
    offset = C * colourDepth
    
    Do While C < bm.bmWidth
    If bytes(offset, R) <> 255 Or _
    bytes(offset + 1, R) <> 255 Or _
    bytes(offset + 2, R) <> 255 Then Exit Do
    C = C + 1
    offset = offset + colourDepth
    Loop
    start_c = C
    
    Do While C < bm.bmWidth
    If bytes(offset, R) = 255 And _
    bytes(offset + 1, R) = 255 And _
    bytes(offset + 2, R) = 255 _
    Then Exit Do
    C = C + 1
    offset = offset + colourDepth
    Loop
    stop_c = C
    
    If start_c < bm.bmWidth Then
    If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1
    
    ' 建立区域
    new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)
    
    If combined_rgn = 0 Then
    combined_rgn = new_rgn
    Else
    CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
    DeleteObject new_rgn
    End If
    End If
    Loop
    Next R
    
    Case 32:
    colourDepth = 4
    
    ReDim longs(0 To bm.bmWidthBytes \ 4 - 1, 0 To bm.bmHeight - 1)
    
    GetBitmapBits pic.Image, bm.bmHeight * bm.bmWidthBytes, longs(0, 0)
    
    
    For R = 0 To bm.bmHeight - 2
    
    C = 0
    Do While C < bm.bmWidth
    start_c = 0
    stop_c = 0
    
    Do While C < bm.bmWidth
    If (longs(C, R) And &HFFFFFF) <> &HFFFFFF Then Exit Do
    C = C + 1
    Loop
    start_c = C
    
    Do While C < bm.bmWidth
    If (longs(C, R) And &HFFFFFF) = &HFFFFFF Then Exit Do
    C = C + 1
    Loop
    stop_c = C
    
    If start_c < bm.bmWidth Then
    If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1
    
    new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)
    
    If combined_rgn = 0 Then
    combined_rgn = new_rgn
    Else
    CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
    DeleteObject new_rgn
    End If
    End If
    Loop
    Next R
    
    Case Else
    MsgBox "对不起，程序必须在 16位, 24-位 或 32-位 颜色下。", _
    vbExclamation + vbOKOnly
    
    Exit Sub
    End Select
    
    ' 设置表单外观为建立区域
    SetWindowRgn frm.hWnd, combined_rgn, True
    DeleteObject combined_rgn
End Sub