Transparencies in Userform

[audeser]

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 annoying thing with the irregular shapes, the darker border. I'm not so good with API functions in this question, so any light on this will come very handy. Is there anything I'm missing here? I tried to generate a polygonal region, but (commented code), don't know if could do something with that dark border.

Oh other hand, I have modified the region of one sample of Jaafar Tribak Drawing Shapes on userForm, the one that draws some shapes on the userform, and then apply to them an alpha function, but the thing looks even ugglier than with the GDI function and the alphablend, so I discarded that way. For example, in that sample of Jaafar, if you look closer, the triangle (or any non rectangular shape) has a rectangular background, so anything that gets drawn below it will be occluded by the hulling rectangle, instead of the only that below the propper polygon.

Hope I have explained it clear.

 

[audeser]

As usual, Jaafar worked it previously: Dragging Controls - Unleashing the power of VBA with Win32 API programming.

I think I have the solution here. It did not appear on a search on the forum for "Transparent;Transparencies;...", but looking on that user posts... !

 

[audeser]

Not that easy. Still no solution for irregular shapes.

 

[Jaafar Tribak]

Hi audeser
,
Did you see this from Andy Pope ? Draw on userform

 

[audeser]

Hi @Jaafar Tribak,

yes, I already know about Andy Pope's implementation. But as you can see, it's not the same thing. He is tricking with the image capture... I'm "trying" not to do so.

My idea is to make a somewhat "3D object viewer". Right now, I've nearly finished a "poor-man" AutoCAD app; and the 3D should be the next step. For that kind of app, I need to get the sides of the objects (composed of several triangles) without overlapping the region outside the shape (mainly, get a subregion tight to the triangle). It's not really for the transparency, but as with transparency it will be the hardest to get, gone for it.
I'm not trying Andy's solution as using Excel for such solution could be extremely slow for too much shapes.
The basic math for 3D is simple (here and here), so it's possible on Excel, and even better with VBA, so it would be dissapointing if all these only to trip on the finish line. If I cannot get this thing achieved, better discard the 3D thing. My other options are via external plug-ins (given that I do not recall on any ActiveX-OCX yet, is something I try to avoid with my bests).

I already get the objects drawn in the userform (... perfect if rectangles), and I can even set a transparency with levels for the "alpha channel", so even if I get the shapes one over the next I can see through them. But what I don't really know if I could ever get rid of the enveloping rectangle in other shapes, that "greyish" sorrounding that is killing me.

I was in the hope there could be a parameter, or another API to get rid of these outbounds, any that I don't know but do the trick... I suppose if any, it could be one from the list REGION APIs. You have tried some on your Drawing Shapes on userForm, but there was no "visual warning" as the rectangular shapes were above the other shapes. If the rectangular was on the back, it will be covered by each "superectangle" of each shape above it.


If not, how the Excel shapes get drawn in the worksheets if that is done via some windows API?

Kind regards

 

[Jaafar Tribak]

Hi audeser

I am not versed in 3D graphics and the code in Drawing Shapes on userForm, was very basic.

The reason the irregular shapes had no transparent background is because the images were drawn on a Static control.

There are a couple of APIs to make the background transparent but since the static control is a child window of the host parent userform, transparency can be problematic.

You can always draw directly onto the form DC and it should get you rid of the annoying background.

Demo File : DrawOnForm.xls


As you can see in the image below, the shapes now have a transparent background using the new code.




Here is a trimed version of the code :

Option Explicit

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

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If Win64 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
    Private Declare PtrSafe Function Polygon Lib "gdi32" (ByVal lShapeDC As LongPtr, lpPoint As Any, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal lShapeDC As LongPtr, ByVal hRgn As LongPtr, ByVal hFrameBrush As LongPtr) As Long
    Private Declare PtrSafe Function FrameRgn Lib "gdi32" (ByVal lShapeDC As LongPtr, ByVal hRgn As LongPtr, ByVal hFrameBrush As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc1 As LongPtr) As Long
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 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
#End If


Public Sub AddShape( _
        Form As Object, _
        eShape As Shp, _
        Left As Long, _
        Top As Long, _
        Width As Long, _
        Height As Long, _
        Optional Fill As Variant _
   )
     
    Const lFrameWidth As Long = 1
    Const lFrameHeight As Long = 1

    #If Win64 Then
        Dim hRgn As LongLong, hFillBrush As LongLong, hFrameBrush As LongLong, hwnd As LongLong, hDc As LongLong
    #Else
        Dim hRgn As Long, hFillBrush As Long, hFrameBrush As Long, hwnd As Long, hDc As Long
    #End If
 
    Dim poly(1 To 3) As POINTAPI

    Call IUnknown_GetWindow(Form, VarPtr(hwnd))
    hDc = GetDC(hwnd)
 
    If IsMissing(Fill) Then Fill = vbWhite
 
    hFillBrush = CreateSolidBrush(Fill)
    hFrameBrush = CreateSolidBrush(vbBlack)
 
    DoEvents
 
    Select Case eShape
        Case Is = triangle
            poly(1).X = Left + Width / 2
            poly(1).Y = Top
            poly(2).X = Left + Width
            poly(2).Y = Top + Height
            poly(3).X = Left
            poly(3).Y = Top + Height
            Polygon hDc, poly(1), 3
            hRgn = CreatePolygonRgn(poly(1), 3, 1)
            Call FillRgn(hDc, hRgn, hFillBrush)
            Call FrameRgn(hDc, hRgn, hFrameBrush, lFrameWidth, lFrameHeight)
        Case Is = Ellipse
            hRgn = CreateEllipticRgn(Left, Top, Width, Height)
            Call FillRgn(hDc, hRgn, hFillBrush)
            Call FrameRgn(hDc, hRgn, hFrameBrush, lFrameWidth, lFrameHeight)
        Case Is = Rectangle
            hRgn = CreateRectRgn(Left, Top, Width, Height)
            Call FillRgn(hDc, hRgn, hFillBrush)
            Call FrameRgn(hDc, hRgn, hFrameBrush, lFrameWidth, lFrameHeight)
    End Select
 
    Call ReleaseDC(hwnd, hDc)
    Call DeleteObject(hRgn)
    Call DeleteObject(hFillBrush)
    Call DeleteObject(hFrameBrush)

End Sub

Form code:

Option Explicit

Private Sub UserForm_Activate()
    Call AddShape(Me, triangle, 100, 0, 200, 200, vbCyan)
    Call AddShape(Me, Ellipse, 200, 50, 150, 100, vbYellow)
    Call AddShape(Me, Ellipse, 200, 150, 250, 250, vbRed)
End Sub

Obviously, this is just a demonstration and is by no means a finished code... Thre are many things that still need to be done, such as subclassing the form in order to intercept the WM_PAINT message, maybe performing the drawing in memory memory (double buffering) and a way of making the ugly shape's borders smooth (anti-aliasing effect)

 

[audeser]

Your code works fantastic, but the API does not have the performance I would expect.

I put a loop, in order to test, and to draw 3*1.000 shapes it takes around 17 seconds in my machine (i78400 64Gb).
So, to speed things a bit, I dissasemble the hWnd+hDC part and moved to the UserForm_Initialize procedure.
Also, pens/brushes/fills object can be created only once, and get them stored in an array with basic colors (for vbBlack to vbSomeColor). All these Objects should be kept alive until the UserForms_Terminate is called. This handles could be called by number, as AutoCAD will do, so the array is a nice trick for me.

If going for the extreme performance, the DoEvents is a bit time operation, so moved to the test loop... just to still have some control over the ESCape.
Finally, the Select Case is more time consuming compared with cascade IF, but it's unnotizable for 10.000 runs, so I left it there.

Now it's on the 2 seconds mark for that 3*1.000 shapes... although still 16 seconds for 30.000 (that's not perfomance). But it's so fast that if the loop is reduced to "1", it does the draw before the Userform gets shown... odd behaviour. I will have to force some miliseconds Sleep here.

In my interest to better performance, I used your code from here, but althought the 30.000 shapes then got down to 4 seconds , I couldnt make it show the shapes... Also, I got an error 91 with a "With" block, probably related to the hWnd being destroyed, so I uncommented the code. But there could be room to investigate.

To complicate the things even further, I tried not to destroy the frames/regions object created, but find that there is a limit, nearly on the 50.000 regions that overwhelms Excel and makes it unoperative (--> it can only crash or forced to close). So the hRng release have to stay at the end of each shape created. I suppose this somehow will limit me to get some interaction with the drawings. I could try to find the real limit and keep some regions alive until user desires.

My modifications are as shown below.

for the userform, now the code is:

Option Explicit

#If Win64 Then
    Dim hwnd As LongPtr, hDc As LongPtr
    Dim hFillBrush() As LongPtr, hFrameBrush() As LongPtr
#Else
    Dim hwnd As Long, hDc As Long
    Dim hFillBrush() As Long, hFrameBrush() As Long
#End If

#If Win64 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
    Private Declare PtrSafe Function Polygon Lib "gdi32" (ByVal lShapeDC As LongPtr, lpPoint As Any, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal lShapeDC As LongPtr, ByVal hRgn As LongPtr, ByVal hFrameBrush As LongPtr) As Long
    Private Declare PtrSafe Function FrameRgn Lib "gdi32" (ByVal lShapeDC As LongPtr, ByVal hRgn As LongPtr, ByVal hFrameBrush As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc1 As LongPtr) As Long

    'Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPtr ' if error, try wParam As LongPtr
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 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 SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
    Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Long) As Long
#End If

''!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Property Let ScreenUpdating(ByVal vNewValue As Boolean)
'    Const WM_SETREDRAW = &HB
'    '#If Win64 Then
'    '    Dim Hwnd As LongPtr
'    '#Else
'    '    Dim Hwnd As Long
'    '#End If
'    'Call IUnknown_GetWindow(Me, VarPtr(Hwnd))
'    Call SendMessage(hwnd, ByVal WM_SETREDRAW, ByVal CLng(vNewValue), 0)
'End Property
'
'Private Sub NotRefresh()
'    On Error GoTo errHandler
'    Me.ScreenUpdating = False
'    'With Me.Controls.Add("Forms.TextBox.1", "TextBox1", False)
'    '    .Top = 20
'    '    .Left = 20
'    '    .Visible = True
'    'End With
'    Me.Hide
'    Me.Show
'errHandler:
'    Call cmdRefresher_Click 'Me.ScreenUpdating = True  ' this line gives me bug on Office 2019 x32
'End Sub
'Private Sub cmdRefresher_Click()
''Stop
'    Me.ScreenUpdating = True
'End Sub
''Private Sub Refresher()
''    Me.ScreenUpdating = True
''End Sub
''!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    'If IsMissing(Fill) Then Fill = vbWhite
    ReDim hFillBrush(0 To 56)
    ReDim hFrameBrush(0 To 56)

    Dim lgColor As Long
    Dim strColor As String
  
    For lgColor = LBound(hFillBrush) To UBound(hFillBrush)
        ActiveCell.Interior.ColorIndex = lgColor
        'strColor = VBA.Hex(ActiveCell.Interior.Color)
        'strColor = VBA.Right("000000" & strColor, 6)
        'Excel shows nibbles in reverse order so make it as RGB
        strColor = VBA.Right(strColor, 2) & VBA.Mid(strColor, 3, 2) & VBA.Left(strColor, 2)
        'to get each byte component from the RGB value: VBA.cDec("&H" & --)
        hFillBrush(lgColor) = CreateSolidBrush(ActiveCell.Interior.Color)
        hFrameBrush(lgColor) = CreateSolidBrush(ActiveCell.Interior.Color)
    Next lgColor
    
    'Call NotRefresh

    Call IUnknown_GetWindow(Me, VarPtr(hwnd))
    hDc = GetDC(hwnd)
End Sub

Private Sub UserForm_Activate()
    Dim cnt As Long
    Dim startTime As Date
    Dim lgColor As Long
    
    startTime = Timer
    For cnt = 1 To 1
        lgColor = VBA.CInt(VBA.Rnd() * 16)
        Call AddShape(hDc, triangle, 100, 0, 200, 200, hFillBrush(lgColor), hFrameBrush(lgColor))
        lgColor = VBA.CInt(VBA.Rnd() * 16)
        Call AddShape(hDc, Ellipse, 200, 50, 150, 100, hFillBrush(lgColor), hFrameBrush(lgColor))
        lgColor = VBA.CInt(VBA.Rnd() * 16)
        Call AddShape(hDc, Ellipse, 200, 150, 250, 250, hFillBrush(lgColor), hFrameBrush(lgColor))
        DoEvents
    Next cnt
    MsgBox "Test completed: " & VBA.Format((Timer - startTime) / 86400, "hh:mm:ss")
End Sub

Private Sub UserForm_Terminate()
    Dim lgColor As Long
    
    Call ReleaseDC(hwnd, hDc)
    
    For lgColor = LBound(hFillBrush) To UBound(hFillBrush)
        Call DeleteObject(hFillBrush(lgColor))
        Call DeleteObject(hFrameBrush(lgColor))
    Next lgColor
    Erase hFillBrush()
    Erase hFrameBrush()
End Sub

#If Win64 Then
Private Sub AddShape(hDc As LongPtr, _
                     eShape As Shp, _
                     Left As Long, _
                     Top As Long, _
                     Width As Long, _
                     Height As Long, _
                     Optional hFillBrush As LongPtr, _
                     Optional hFrameBrush As LongPtr)
    Dim hRgn As LongPtr  ' still to be analized...
#Else
Private Sub AddShape(hDc As Long, _
                     eShape As Shp, _
                     Left As Long, _
                     Top As Long, _
                     Width As Long, _
                     Height As Long, _
                     Optional hFillBrush As Long, _
                     Optional hFrameBrush As Long)
    Dim hRgn As Long    ' still to be analized...
#End If
    
    Const lFrameWidth As Long = 1
    Const lFrameHeight As Long = 1

    Select Case eShape
        Case Is = triangle
            Dim poly() As POINTAPI
            ReDim poly(1 To 3)
            poly(1).X = Left + Width / 2
            poly(1).Y = Top
            poly(2).X = Left + Width
            poly(2).Y = Top + Height
            poly(3).X = Left
            poly(3).Y = Top + Height
            Polygon hDc, poly(1), 3
            hRgn = CreatePolygonRgn(poly(1), 3, 1)
            Call FillRgn(hDc, hRgn, hFillBrush)
            Call FrameRgn(hDc, hRgn, hFrameBrush, lFrameWidth, lFrameHeight)
        Case Is = Ellipse
            hRgn = CreateEllipticRgn(Left, Top, Width, Height)
            Call FillRgn(hDc, hRgn, hFillBrush)
            Call FrameRgn(hDc, hRgn, hFrameBrush, lFrameWidth, lFrameHeight)
        Case Is = Rectangle
            hRgn = CreateRectRgn(Left, Top, Width, Height)
            Call FillRgn(hDc, hRgn, hFillBrush)
            Call FrameRgn(hDc, hRgn, hFrameBrush, lFrameWidth, lFrameHeight)
    End Select
    
    Call DeleteObject(hRgn)
End Sub

For the module, the code:

Option Explicit

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

Public Type POINTAPI
    X As Long
    Y As Long
End Type

As always, thank you very much @Jaafar Tribak, I'll continue to study on this and the transparencies, but the post can be considered SOLVED.

 

[Jaafar Tribak]

@audeser

I put a loop, in order to test, and to draw 3*1.000 shapes it takes around 17 seconds in my machine (i78400 64Gb)

With that amount of shapes to be drawn, If you know before hand what you are going to draw, I would try drawing the shapes onto an array of memory DCs double buffering upon the form loading and then I would just BitBlit each memory DC onto the form DC later on when needed... Hopefully, that would increase performance and avoid screen-flicker.

 

[Jaafar Tribak]

Also, just noticed an error in the code in post#6

The first IF contitional compilation statement is wrong.

This :
#If Win64 Then
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172"......

..............................................
Should become this:
#If VBA7 Then
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" .....
.........................