' Load the image
    Set pic(1) = Picture1.Image
   
    Picture1.picture = pic(1)

    ' Scan the image
    Call rgnBasic.ScanPicture(pic(1))

    ' Offset the Shape to allow for the form header.
    Call rgnBasic.OffsetHeader(Me)

    Me.picture = pic(1) ' Set the Form Background
    Call rgnBasic.ApplyRgn(Me.hWnd) ' Set the Form Shape
    CurrentRgn = rgnBasic.hndRegion ' Set the Current Shape

Dim rgnBasic As New Region
Dim rgnExtended As New Region
Dim CurrentRgn As Long
Dim pic(0 To 1) As New StdPicture

Option Explicit

Public hndRegion As Long
Private DIB As New cDIBSection
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long

Private Sub Class_Terminate()
    If hndRegion <> 0 Then Call DeleteObject(hndRegion)
End Sub

Public Sub ApplyRgn(ByVal hWnd As Long)
'
'   When the setWinowRgn function gets a handle to a region it applies and
'   deletes the region.  Therefore you cannot call the function twice with
'   the handle to the same region.  Therefore I make a copy of the region
'   for windows to apply and delete.
'
    Dim hndRegionCopy As Long
   
    hndRegionCopy = CreateRectRgn(0, 0, 0, 0) ' Create a blank region

    Call CombineRgn(hndRegionCopy, hndRegion, hndRegionCopy, RGN_OR) ' Copy the region
    Call SetWindowRgn(hWnd, hndRegionCopy, True)
End Sub

Public Sub ScanPicture(ByVal picture As StdPicture, Optional transColor As Long = vbNull)
On Error Resume Next
    Dim Rgn2 As Long
   
    hndRegion = CreateRectRgn(0, 0, 0, 0)
   
    Dim x As Long, y As Long
    Dim SPos As Long, EPos As Long
    Dim Wid As Long, Hgt As Long
    Dim bDib() As Byte
    Dim tSA As SAFEARRAY2D
     
    'get the picture size of the form
    Call DIB.CreateFromPicture(picture)
   
    Wid = DIB.Width
    Hgt = DIB.Height
   
    ' have the local matrix point to bitmap pixels
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = DIB.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = DIB.BytesPerScanLine
        .pvData = DIB.DIBSectionBitsPtr
    End With
   
    Call CopyMemory(ByVal VarPtrArray(bDib), VarPtr(tSA), 4)
   
    ' if there is no transColor specified, use the first pixel as the transparent color
    If transColor = vbNull Then transColor = RGB(bDib(0, 0), bDib(1, 0), bDib(2, 0))
   
    For y = 0 To DIB.Height - 1 'line scan
        x = -3
        Do
            Rgn2 = 0
            x = x + 3
           
            While RGB(bDib(x, y), bDib(x + 1, y), bDib(x + 2, y)) = transColor And (x < DIB.Width * 3 - 3)
                x = x + 3 'skip the transparent point
            Wend
           
            SPos = x / 3
           
            While RGB(bDib(x, y), bDib(x + 1, y), bDib(x + 2, y)) <> transColor And (x < DIB.Width * 3 - 3)
                x = x + 3 'skip the nontransparent point
            Wend
           
            EPos = x / 3
           
            'combine the region
            If SPos <= EPos Then
                Rgn2 = CreateRectRgn(SPos, DIB.Height - y, EPos, DIB.Height - 1 - y)
                Call CombineRgn(hndRegion, hndRegion, Rgn2, RGN_OR)
                Call DeleteObject(Rgn2)
            End If
        Loop Until x >= DIB.Width * 3 - 3
    Next y
   
    Call CopyMemory(ByVal VarPtrArray(bDib), 0&, 4)
End Sub

Public Sub OffsetHeader(ByRef tmpForm As Form)
    With tmpForm
        If .BorderStyle <> 0 Then
            Dim xoff As Long, yoff As Long
           
            .ScaleMode = vbPixels
           
            xoff = (.ScaleX(.Width, vbTwips, vbPixels) - .ScaleWidth) / 2
            yoff = .ScaleY(.Height, vbTwips, vbPixels) - .ScaleHeight - xoff
   
            Call OffsetRgn(hndRegion, xoff, yoff)
        End If
    End With
End Sub

Dim rgnBasic As New Region
Dim rgnExtended As New Region

Private DIB As New cDIBSection

Private DIB As New cDIBSection

Option Explicit

Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
    (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO, _
    ByVal un As Long, _
    lplpVoid As Long, _
    ByVal handle As Long, _
    ByVal dw As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private m_hDIb As Long
Private m_hBmpOld As Long
Private m_hDC As Long
Private m_lPtr As Long
Private m_tBI As BITMAPINFO

Public Function CreateDIB( _
        ByVal lHDC As Long, _
        ByVal lWidth As Long, _
        ByVal lHeight As Long, _
        ByRef hDib As Long _
    ) As Boolean
    With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    hDib = CreateDIBSection( _
            lHDC, _
            m_tBI, _
            DIB_RGB_COLORS, _
            m_lPtr, _
            0, 0)
    CreateDIB = (hDib <> 0)
End Function
Public Function CreateFromPicture( _
        ByRef picThis As StdPicture _
    )
Dim lHDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
   
    GetObjectAPI picThis.handle, Len(tBMP), tBMP
    If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
        lhDCDesktop = GetDC(GetDesktopWindow())
        If (lhDCDesktop <> 0) Then
            lHDC = CreateCompatibleDC(lhDCDesktop)
            DeleteDC lhDCDesktop
            If (lHDC <> 0) Then
                lhBmpOld = SelectObject(lHDC, picThis.handle)
                LoadPictureBlt lHDC
                SelectObject lHDC, lhBmpOld
                DeleteObject lHDC
            End If
        End If
    End If
End Function

Public Function Create( _
        ByVal lWidth As Long, _
        ByVal lHeight As Long _
    ) As Boolean
    ClearUp
    m_hDC = CreateCompatibleDC(0)
    If (m_hDC <> 0) Then
        If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
            m_hBmpOld = SelectObject(m_hDC, m_hDIb)
            Create = True
        Else
            DeleteObject m_hDC
            m_hDC = 0
        End If
    End If
End Function
Public Property Get BytesPerScanLine() As Long
    ' Scans must align on dword boundaries:
    BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property

Public Property Get Width() As Long
    Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
    Height = m_tBI.bmiHeader.biHeight
End Property

Public Sub LoadPictureBlt( _
        ByVal lHDC As Long, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal lSrcWidth As Long = -1, _
        Optional ByVal lSrcHeight As Long = -1, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
    )
    If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
    If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
    BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lHDC, lSrcLeft, lSrcTop, eRop
End Sub

Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property

Public Sub ClearUp()
    If (m_hDC <> 0) Then
        If (m_hDIb <> 0) Then
            SelectObject m_hDC, m_hBmpOld
            DeleteObject m_hDIb
        End If
        DeleteObject m_hDC
    End If
    m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub

Private Sub Class_Terminate()
    ClearUp
End Sub

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 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 GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Type BITMAP '14 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&

Private Const pixR As Integer = 3
Private Const pixG As Integer = 2
Private Const pixB As Integer = 1
Private Sub UnRGB(ByRef color As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
    r = color And &HFF&
    g = (color And &HFF00&) \ &H100&
    b = (color And &HFF0000) \ &H10000
End Sub
' Restrict the form to its "transparent" pixels.
Private Sub TrimPicture(ByVal pic As PictureBox, ByVal transparent_color As Long)
Const RGN_OR = 2
Dim bitmap_info As BITMAPINFO
Dim pixels() As Byte
Dim bytes_per_scanLine As Integer
Dim pad_per_scanLine As Integer
Dim transparent_r As Byte
Dim transparent_g As Byte
Dim transparent_b As Byte
Dim wid As Integer
Dim hgt As Integer
Dim X As Integer
Dim Y As Integer
Dim start_x As Integer
Dim stop_x As Integer
Dim combined_rgn As Long
Dim new_rgn As Long

    ' Prepare the bitmap description.
    With bitmap_info.bmiHeader
        .biSize = 40
        .biWidth = picTest.ScaleWidth
        ' Use negative height to scan top-down.
        .biHeight = -picTest.ScaleHeight
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With

    ' Load the bitmap's data.
    wid = picTest.ScaleWidth
    hgt = picTest.ScaleHeight
    ReDim pixels(1 To 4, 0 To wid - 1, 0 To hgt - 1)
    GetDIBits picTest.hdc, picTest.Image, _
        0, picTest.ScaleHeight, pixels(1, 0, 0), _
        bitmap_info, DIB_RGB_COLORS

    ' Break the transparent color into its components.
    UnRGB transparent_color, transparent_r, transparent_g, transparent_b

    ' Create the PictureBox's regions.
    For Y = 0 To hgt - 1
        ' Create a region for this row.
        X = 1
        Do While X < wid
            start_x = 0
            stop_x = 0

            ' Find the next non-transparent column.
            Do While X < wid
                If pixels(pixR, X, Y) <> transparent_r Or _
                   pixels(pixG, X, Y) <> transparent_g Or _
                   pixels(pixB, X, Y) <> transparent_b _
                Then
                    Exit Do
                End If
                X = X + 1
            Loop
            start_x = X

            ' Find the next transparent column.
            Do While X < wid
                If pixels(pixR, X, Y) = transparent_r And _
                   pixels(pixG, X, Y) = transparent_g And _
                   pixels(pixB, X, Y) = transparent_b _
                Then
                    Exit Do
                End If
                X = X + 1
            Loop
            stop_x = X

            ' Make a region from start_x to stop_x.
            If start_x < wid Then
                If stop_x >= wid Then stop_x = wid - 1

                ' Create the region.
                new_rgn = CreateRectRgn( _
                    start_x, Y, stop_x, Y + 1)

                ' Add it to what we have so far.
                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 Y
   
    ' Restrict the PictureBox to the region.
    SetWindowRgn pic.hWnd, combined_rgn, True
    DeleteObject combined_rgn
End Sub

Private Sub pictest_Click()
    Unload Me
End Sub


Private Sub Form_Load()
    ' Center the form.
    Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2

    ' Move the picture on top of the other controls.
    picTest.ZOrder
    picTest.ScaleMode = vbPixels
    picTest.AutoRedraw = True
    picTest.Picture = picTest.Image

    ' Trim the picture.
    TrimPicture picTest, &HFF00FF
End Sub

Private Sub Form_Load()
    ' Center the form.
    Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2

    ' Move the picture on top of the other controls.
    picTest.ZOrder
    picTest.ScaleMode = vbPixels
    picTest.AutoRedraw = True
    picTest.Picture = picTest.Image

    ' Trim the picture.
    TrimPicture picTest, &HFF00FF

    ' Move the picture on top of the other controls.
    picTest2.ZOrder
    picTest2.ScaleMode = vbPixels
    picTest2.AutoRedraw = True
    picTest2.Picture = picTest2.Image

    TrimPicture picTest2, &HFF00FF
End Sub