ShapeEx :_ Make your shapes float and make their background transparent

[Jaafar Tribak]

Hi all,

Been working on this little project and thought I would post here what I have come up with so far.

Essentially, the code enables you to clone worksheet shapes in order to make the shapes float over the worksheet and also gives you the possibility to make an area of the shape transparent based on the color of your choice. (normally the background)

It uses a simple interface like in the following example :

Sub Test()

    Dim ShapeEx1 As IShapeEX
    
    Set ShapeEx1 = New CShapeEx
    [B]ShapeEx1.CreateFrom Sheet1.Shapes("Image 1"), vbBlue[/B]

End Sub

where Shapes(Image 1") is the shape we are copying and Blue is the color covering the area we want to make transparent.

The clone shapes have a right-click menu to dismiss them.

Workbook example.


Here is the whole project code in case the workbook link expires:

1- Add a Class module to your project and give it the name of IShapeEX - This will be the Interface code. Place this code in the module :

Option Explicit

Public Sub CreateFrom( _
Shape As Shape, _
Optional TransColor As Long = vbNull _
)

End Sub

2- Add a blank UserForm and give it the name of CShapeEx - Place this in the form module :

Option Explicit

Implements IShapeEX

Private WithEvents WBEvents As Workbook

Private Type WIN_METRICS
    XBorders As Long
    TitleHeight As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom 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
    biRUsed As Long
    biRImportant As Long
End Type
 
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
End Type
 
Private Type MemoryBitmap
    hdc As Long
    hBM As Long
    oldhDC As Long
    wid As Long
    hgt As Long
    bitmap_info As BITMAPINFO
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 OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
 
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
 
Private Declare Function CloseClipboard Lib "user32" _
() As Long
 
Private Declare Function _
OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long

Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long) As Long

Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, ByRef lpRect As RECT) 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 GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, ByRef lpRect As RECT) As Long

Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) _
As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) _
As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc 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 DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function SetParent Lib "user32.dll" _
(ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long

Private Declare Function OffsetRgn Lib "gdi32" _
(ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) 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 Boolean) As Long

Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal _
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
    
Private Declare Sub ReleaseCapture Lib "user32" ()

Private Declare Function SetFocus Lib "user32.dll" _
(ByVal hwnd As Long) As Long

Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const BI_RGB = 0&
Private Const SRCCOPY = &HCC0020
Private Const SM_CYCAPTION = 4
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8

Private lHwnd As Long
Private hndRegion As Long
Private memory_bitmap As MemoryBitmap
Private lTransColor As Long
Private oShape As Shape

Private Sub IShapeEX_CreateFrom( _
Shape As Shape, _
Optional TransColor As Long = 1&)

    Dim oPic As StdPicture
    Dim lWbHwnd As Long
    
    Set oShape = Shape
    lTransColor = TransColor
    Set WBEvents = ThisWorkbook
    Names.Add "ShapesExCount", ShapesExCount, False
    lHwnd = FindWindow("ThunderXFrame", Me.Caption)
    If lHwnd = 0 Then lHwnd = FindWindow("ThunderDFrame", Me.Caption)
    Set oPic = PicFromShape(Shape)
    Me.Width = (Shape.Width + WinMetrics.XBorders)
    Me.Height = (Shape.Height + WinMetrics.TitleHeight)
    Call ScanPicture(oPic, lTransColor)
    Call SetRegion(lHwnd)
    lWbHwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    lWbHwnd = FindWindowEx(lWbHwnd, 0, "EXCEL7", vbNullString)
    SetParent lHwnd, lWbHwnd
    Me.StartUpPosition = 0
    Me.Top = Evaluate("ShapesExCount") * 20
    Me.Left = Evaluate("ShapesExCount") * 20
    Me.MousePointer = fmMousePointerCross
    Me.Show vbModeless

End Sub

Private Function PicFromShape(Shape As Shape) As StdPicture
 
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim hPtr As Long
 
    Shape.CopyPicture xlScreen, xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr
        .hPal = 0
    End With
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    Set PicFromShape = IPic
    SavePicture IPic, Environ("Temp") & "\Temp.bmp"
 
End Function

Private Sub ScanPicture( _
ByVal Picture As StdPicture, _
Optional TransColor As Long = vbNull)

    Dim hMainDC As Long
    Dim oTempRgn As Long
    Dim X As Long, Y As Long
    Dim lStart As Long
    Dim bm As BITMAP

    hndRegion = CreateRectRgn(0, 0, 0, 0)
    Call GetObjectAPI(Picture.handle, Len(bm), bm)
    memory_bitmap = MakeMemoryBitmap(bm.bmWidth, bm.bmHeight)
    hMainDC = memory_bitmap.hdc
    DeleteObject (SelectObject(hMainDC, Picture.handle))
    For Y = 4 To memory_bitmap.hgt - 4
        X = 4
        Do While X < memory_bitmap.wid - 4
            Do While X < memory_bitmap.wid - 4 And _
                GetPixel(hMainDC, X, Y) = TransColor
                X = X + 1
            Loop
            If X < memory_bitmap.wid - 4 Then
                lStart = X
                Do While X < memory_bitmap.wid - 4 And _
                    GetPixel(hMainDC, X, Y) <> TransColor
                    X = X + 1
                Loop
                If X > memory_bitmap.wid - 4 Then X = memory_bitmap.wid - 4
                oTempRgn = CreateRectRgn(lStart, Y, X, Y + 1)
                Call CombineRgn(hndRegion, hndRegion, oTempRgn, 2)
                Call DeleteObject(oTempRgn)
            End If
        Loop
    Next Y
    
End Sub

Private Sub SetRegion(ByVal hwnd As Long)

    Dim Xoff As Long, Yoff As Long
    Dim tCRect As RECT

    GetClientRect lHwnd, tCRect
    With Me
    Xoff = ((tCRect.Right - tCRect.Left) - memory_bitmap.wid) / 2 _
    + WinMetrics.XBorders
    Yoff = ((tCRect.Bottom - tCRect.Top) - memory_bitmap.hgt) / 2 _
    + WinMetrics.TitleHeight
    Set Me.Picture = LoadPicture _
    (Environ("Temp") & "\Temp.bmp", 0, 0, 0)
    End With
    Call OffsetRgn(hndRegion, Xoff, Yoff)
    Call SetWindowRgn(hwnd, hndRegion, True)

End Sub

Private Function MakeMemoryBitmap _
(W As Long, H As Long) As MemoryBitmap
 
    Dim result As MemoryBitmap
    Dim bytes_per_scanLine As Long
    Dim pad_per_scanLine As Long
    Dim lBmp As Long
    
    With result.bitmap_info.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(result.bitmap_info.bmiHeader)
        .biWidth = W
        .biHeight = H
        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
    result.hdc = CreateCompatibleDC(0)
    lBmp = CreateCompatibleBitmap(result.hdc, W, H)
    DeleteObject (SelectObject(result.hdc, result.hBM))
    DeleteObject (lBmp)
    result.wid = W
    result.hgt = H
    MakeMemoryBitmap = result
 
End Function

Private Sub CreateRghtClickMenu()

    Dim objCmb As CommandBar
    
    On Error Resume Next
    CommandBars("ShapeMenu").Delete
    Set objCmb = Application.CommandBars.Add _
    (Position:=msoBarPopup, Temporary:=True)
    With objCmb
        objCmb.Name = "ShapeMenu"
        With .Controls.Add(msoControlButton)
            .Caption = "Close me"
            .OnAction = "'CloseShape " & ObjPtr(Me) & "'"
        End With
    End With
    On Error GoTo 0
    
End Sub

Private Function ShapesExCount() As Long

    Dim frm As Object
    
    For Each frm In VBA.UserForms
     If frm.Name = "CShapeEx" Then ShapesExCount = ShapesExCount + 1
    Next
    
End Function

Private Function WinMetrics() As WIN_METRICS

    WinMetrics.TitleHeight = GetSystemMetrics(SM_CYCAPTION) _
    + GetSystemMetrics(SM_CYDLGFRAME)
    WinMetrics.XBorders = GetSystemMetrics(SM_CXDLGFRAME)

End Function

Private Sub UserForm_Click()

On Error Resume Next

 Run oShape.OnAction
If Err.Number <> 0 Then
        MsgBox "hello... No Macro is assigned to :" & oShape.Name
    End If
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If Button = 2 Then
        Call CreateRghtClickMenu
        CommandBars("ShapeMenu").ShowPopup
    End If
 
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCAPTION = 2
    
    SetFocus lHwnd
    If Button = 1 Then
        ReleaseCapture
        SendMessage lHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    End If
    
End Sub

Private Sub UserForm_Terminate()

    If ShapesExCount = 1 Then
        Names("ShapesExCount").Delete
        CommandBars("ShapeMenu").Delete
        Kill Environ("Temp") & "\Temp.bmp"
        DeleteObject (hndRegion)
    End If
    
End Sub


Private Sub WBEvents_SheetActivate(ByVal Sh As Object)
    
    If Not Sh Is oShape.Parent.Parent Then Me.Hide Else Me.Show vbModeless
        
End Sub

3- Add a Standard Module and put the following code in it :

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
pDest As Any, pSrc As Any, ByVal ByteLen As Long)

Public Sub CloseShape(ByVal Ptr As Long)

    Dim oTempObj As Object
    
    CopyMemory oTempObj, Ptr, 4
    Unload oTempObj
    CopyMemory oTempObj, 0&, 4

End Sub

Tested on excel 2007 only.

 

[GlennUK]

Thanks Jaafar, I'll have a play with this when I have some spare time ( i.e. not at work ).

It looks interesting

 

[Jon von der Heyden]

Works for me on Win7 64-bit running Excel 2010 32-bit.

Very clever stuff Jaafar, as usual.
I won't pretend to understand, first glance reveals loads of API's that I have never seen or used before.

Not sure where I might ever practically use this but definitely one for the library.

 

[Jaafar Tribak]

Hey thank you both for the interest. Glad it worked for you Jon.

I won't pretend to understand, first glance reveals loads of API's that I have never seen or used before.

Uses mainly graphical functions but the SetWindowRgn API function is the main player here. It is the one that defines the area of the userform that should be drawn.

Sorry the code is not commented...I am still working on the project ... I'll try commenting the code when done.