Drawing Shapes on a UserForm .

[Jaafar Tribak]

This is an attempt to add some basic shapes to an excel userform.The method I have used relies purely on API Region functions as opposed to the approach taken by andy pope who uses built-in excel shapes copied to image controls.

The most difficult part is getting the regions to redraw when the userform is covered under another window because there is no Paint event for excel userforms.

To get around this problem, I have used the Form_Layout event together with subclassing the form and handling the WM_ACTIVATE Window Msg. It is ugly coding but it seems to work.

Due to the above mentioned problems, positionning the Shapes inside the form and adding text to the shapes will need some careful tweaking work on the part of those wanting to adapt the code.


Here is a Workbook Demo.

1- Code in a Standard Module :

'Jaafar Tribak on 08/12/2010.

'Project that adds some basic shapes to an
'excel userform via API Region Functions.
'Tested on xl2003-2007 on Win XP.

Option Explicit

'Public Declarations.
'---------------------
Public lFormDC As Long
Public lFormHwnd As Long

Public Enum Shp
    Rectangle = 0
    Ellipse = 1
    Triangle = 2
End Enum

Public Type FormShape
    hwnd As Long
    Fill As Long
End Type

Public Type POINTAPI
    x As Long
    y As Long
End Type


Public Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) _
As Long

Public Declare Function ScreenToClient Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long

Public Declare Function RealChildWindowFromPoint Lib "user32" _
(ByVal hWndParent As Long, _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long

Public Declare Function GetPixel Lib "gdi32" _
(ByVal lShapeDC As Long, _
ByVal x As Long, ByVal y As Long) As Long

Public Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long


'Private declarations.
'-----------------------
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

 Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type


Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lpParam As Any) As Long

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

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

Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
 
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long


Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long
 

Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long

Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal lShapeDC As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

 
Private Declare Function CreatePolygonRgn Lib "gdi32" _
(lpPoint As Any, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As Long

Private Declare Function Polygon Lib "gdi32" _
(ByVal lShapeDC As Long, _
lpPoint As Any, ByVal nCount 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 CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long

Private Declare Function FillRgn Lib "gdi32" _
(ByVal lShapeDC As Long, _
ByVal hRgn As Long, _
ByVal hFrameBrush As Long) As Long

Private Declare Function GetRgnBox Lib "gdi32" _
(ByVal hRgn As Long, _
lpRect As RECT) As Long

Private Declare Function FrameRgn Lib "gdi32" _
(ByVal lShapeDC As Long, _
ByVal hRgn As Long, _
ByVal hFrameBrush As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long

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

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

Private Declare Function SetBkMode Lib "gdi32.dll" _
(ByVal lShapeDC As Long, _
ByVal nBkMode As Long) _
As Long

Private Declare Function DrawText Lib "user32" _
Alias "DrawTextA" _
(ByVal lShapeDC As Long, _
ByVal lpStr As String, _
ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat As Long) As Long


Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long


Private Const GWL_WNDPROC = -4
Private Const WM_ACTIVATE = &H6
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Const WS_CHILD = &H40000000
Private Const WS_EX_TOOLWINDOW = &H80

Private Const FontHeight As Long = 14
Private Const FontWidth As Long = 9
Private Const lFrameWidth As Long = 1
Private Const lFrameHeight As Long = 1
Private Const PtToPix = 96 / 72

Private tFormRect As RECT
Private lPrevWinProc As Long


Public Function AddShape( _
Form As Object, _
eShape As Shp, _
Left As Long, _
Top As Long, _
Width As Long, _
Height As Long, _
Optional Fill As Variant, _
Optional Text As String) As FormShape

    Dim poly(1 To 3) As POINTAPI
    Dim tFont As LOGFONT
    Dim tFrameLB As LOGBRUSH
    Dim tFillLB As LOGBRUSH
    Dim tShapeRect As RECT
    
    Dim lShape As Long
    Dim lFont As Long
    Dim tRgn As Long
    Dim hFillBrush As Long
    Dim hFrameBrush As Long
    Dim lShapeDC As Long
    Dim lNumCoords As Long
    
    'get the form hwnd.
    lFormHwnd = FindWindow(vbNullString, Form.Caption)
    
    'store the form dimensions.
    GetWindowRect lFormHwnd, tFormRect
    
    'subclass the form if not subclassed yet.
    If lPrevWinProc = 0 Then
        lPrevWinProc = SetWindowLong _
        (lFormHwnd, GWL_WNDPROC, AddressOf WinProc)
    End If
    
    
    'create the shape.
    lShape = CreateWindowEx(WS_EX_TOOLWINDOW, "Static", _
    vbNullString, WS_CHILD, Left * PtToPix, Top * PtToPix, _
    Width * PtToPix, Height * PtToPix, lFormHwnd, 0, 0, 0)
    
    'store the form and shape DCs.
    lFormDC = GetDC(lFormHwnd)
    lShapeDC = GetDC(lShape)
    
    SetParent lShape, lFormHwnd
    SetBkMode lShapeDC, 1
    
    'display the shape.
    ShowWindow lShape, 1
    
    'store the shape dimensions.
    GetClientRect lShape, tShapeRect
    
    'define the shape text font.
    tFont.lfHeight = FontHeight
    tFont.lfWidth = FontWidth
    
    'set the frame color
    tFrameLB.lbColor = vbBlack
    hFrameBrush = CreateBrushIndirect(tFrameLB)
    
    'set the fill color
    If IsMissing(Fill) Then
        tFillLB.lbColor = vbWhite
        Fill = vbWhite
    Else
        tFillLB.lbColor = Fill
    End If
    hFillBrush = CreateBrushIndirect(tFillLB)
    
    DoEvents
    
    With tShapeRect
        Select Case eShape
            Case Is = Triangle 'add Triangle shape.
                'define the triangle coordinates
                lNumCoords = 3
                poly(1).x = Width / 2 * PtToPix
                poly(1).y = Top * PtToPix
                poly(2).x = Width * PtToPix
                poly(2).y = Height * PtToPix
                poly(3).x = 0
                poly(3).y = Height * PtToPix
                Polygon lShapeDC, poly(1), lNumCoords
                'create the triangle region.
                tRgn = CreatePolygonRgn(poly(1), lNumCoords, 1)
                'fill the region.
                FillRgn lShapeDC, tRgn, hFillBrush
                'draw the region frame.
                FrameRgn lShapeDC, tRgn, hFrameBrush, _
                lFrameWidth, lFrameHeight
            Case Is = Ellipse 'add ellipse shape.
                'create an elliptic region.
                tRgn = CreateEllipticRgn _
                (.Left, .Top, .Right, .Bottom)
                'fill the region.
                FillRgn lShapeDC, tRgn, hFillBrush
                'draw the region frame.
                FrameRgn lShapeDC, tRgn, hFrameBrush, _
                lFrameWidth, lFrameHeight
            Case Is = Rectangle 'add rectangle shape.
                'create the rectangle region.
                tRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
                'fill the region.
                FillRgn lShapeDC, tRgn, hFillBrush
                'draw the region frame.
                FrameRgn lShapeDC, tRgn, hFrameBrush, _
                lFrameWidth, lFrameHeight
        End Select
    End With
    
    'create Font and select it in the Shapes DCs.
    lFont = CreateFontIndirect(tFont)
    Call SelectObject(lShapeDC, lFont)
    GetRgnBox tRgn, tShapeRect
    
    'add shape text.
    DrawText lShapeDC, Text, Len(Text), tShapeRect, _
    DT_CENTER + DT_VCENTER + DT_SINGLELINE
    
    'release resources.
    DeleteObject tRgn
    DeleteObject hFillBrush
    DeleteObject hFrameBrush
    DeleteObject lFont
    ReleaseDC lShape, lShapeDC
    
    'return function
    AddShape.hwnd = lShape
    AddShape.Fill = CLng(Fill)

End Function


Public Function WinProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

    On Error Resume Next
    
    If uMsg = WM_ACTIVATE Then
        With tFormRect
            MoveWindow hwnd, .Left - 1, .Top, _
            .Right - .Left, .Bottom - .Top, 1
            MoveWindow hwnd, .Left, .Top, _
            .Right - .Left, .Bottom - .Top, 1
        End With
    End If
    
    WinProc = CallWindowProc _
    (lPrevWinProc, hwnd, uMsg, wParam, lParam)

End Function

Public Sub UnSubClassForm(Dummy As Boolean)

    Call SetWindowLong(lFormHwnd, GWL_WNDPROC, lPrevWinProc)
    lPrevWinProc = 0

End Sub

2- Code in the UserForm Module :

Option Explicit

Private lTriangle As FormShape
Private lEllipse1 As FormShape
Private lEllipse2 As FormShape
Private lEllipse3 As FormShape
Private lEllipse4 As FormShape
Private lEllipse5 As FormShape
Private lRectangle As FormShape


Private Sub UserForm_Layout()

    'destroy any preexisting shapes.
    Call DestroyShapes
    
    'add the Shapes to the form.
    lTriangle = AddShape(Me, Triangle, Me.Width / 2, 0, 120, 80, &HFFFF00, "Click Me")
    lEllipse1 = AddShape(Me, Ellipse, 10, 10, 120, 40, vbMagenta, "Click Me")
    lEllipse2 = AddShape(Me, Ellipse, 50, 60, 60, 60, vbYellow, "Click Me")
    lEllipse3 = AddShape(Me, Ellipse, 160, 100, 40, 40, &HFF&)
    lEllipse4 = AddShape(Me, Ellipse, 200, 100, 30, 30, &H8080FF)
    lEllipse5 = AddShape(Me, Ellipse, 230, 100, 20, 20, &HC0C0FF)
    lRectangle = AddShape(Me, Rectangle, 10, 100, 60, 60, , "Click Me")

End Sub

Private Sub UserForm_Click()

    Dim tpt As POINTAPI
    
    GetCursorPos tpt
    
    ScreenToClient lFormHwnd, tpt
    
    'handle the shapes click events.
    Select Case RealChildWindowFromPoint(lFormHwnd, tpt.x, tpt.y)
        Case lTriangle.hwnd
            If GetPixel(lFormDC, tpt.x, tpt.y) = lTriangle.Fill Then
                MsgBox "You clicked Triangle1"
            End If
        Case lEllipse1.hwnd
            If GetPixel(lFormDC, tpt.x, tpt.y) = lEllipse1.Fill Then
                MsgBox "You clicked Ellipse1."
            End If
        Case lEllipse2.hwnd
            If GetPixel(lFormDC, tpt.x, tpt.y) = lEllipse2.Fill Then
                MsgBox "You clicked Ellipse2."
            End If
        Case lRectangle.hwnd
            MsgBox "You clicked Rectangle1"
    End Select


End Sub



Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    'remove the form subclass.
    Call UnSubClassForm(True)

End Sub

Private Sub DestroyShapes()

    DestroyWindow lTriangle.hwnd
    DestroyWindow lEllipse1.hwnd
    DestroyWindow lEllipse2.hwnd
    DestroyWindow lEllipse3.hwnd
    DestroyWindow lEllipse4.hwnd
    DestroyWindow lEllipse5.hwnd
    DestroyWindow lRectangle.hwnd

End Sub

Private Sub CommandButton1_Click()

    Unload Me

End Sub

Note that the userform MUST be shown modal.

 

[JGO]

Thank you for this code it's working great in office2013 32 bit.
Now i'm trying to use this code in office365 64bit.
I discovered you all Declare statements must now include the PtrSafe keyword when running in 64-bit versions of Office.

Also all data types within the statement that need to store 64-bits (including return values and parameters) must be modified to hold 64-bit quantities.

How do i know which statements must be transfered to longptr?
Can anyone help me with that?



Thank you.

 

[Dan_W]

Hi JGO

A good starting resource for working out how best to declare APIs is JKP's website: https://jkp-ads.com/Articles/apideclarations.asp He lists out a set of resources that should help. As it happens, one of my side-projects is code that will go through another workbook or a file, and update the API declarations automatically, but it's still a WIP.

If you want 64bit GDI declarations for the code above, the quickest way to do it is to look at @Jaafar Tribak 's more recent posts, where he very helpfully sets out all the API declarations needed for this type of project. By way of example, check this post.

In terms of the code above, I've also recently started to look at drawing on userforms, and am stuck at Excel constantly crashing everytime I go to close the userform. Hoping the solution is here somewhere.

 

[Jaafar Tribak]

Hi JGO
If you want 64bit GDI declarations for the code above, the quickest way to do it is to look at @Jaafar Tribak 's more recent posts, where he very helpfully sets out all the API declarations needed for this type of project. By way of example, check this post.

In terms of the code above, I've also recently started to look at drawing on userforms, and am stuck at Excel constantly crashing everytime I go to close the userform. Hoping the solution is here somewhere.

This is a x64 continuation of the code in this thread which was brought back to live recently, but the code is not finished (it is just a quick demo):

Transparencies in Userform

Hi all, The question is simple, how to get "nice" transparencies in a userform?. Any work on this topic, really appreciated if you can share. I upload a userform to my dropbox that I have prepared with my findings: Link to dropBox As you can see, I get transparencies, but I have this...

www.mrexcel.com