LabelPlus

[LeandroA]

First of all I want to clarify that this control is based on the Firenze Label project, adapted to GDI + with many aggregates since the previous one depends on vbRichClient5.
They have many properties and events that later I will go with certain data, for the moment I will raise the control with some examples and other controls that accompany.
You can achieve very nice things with this control, it is only a matter of playing with its properties, you can create many controls from this label is a matter of putting a little imagination. I clarify that it does not act as a programmed control, it is a label not a button so it is in the programmer to give the way in which the seal is repainted when the Down and Up mouse is triggered and other events.

Some screenshots of what can be achieved with the LabePlus






sorry for not leaving a help file

Version: 1.5.2
DOWNLOAD

[Albertomi]

Very valuable control, very useful.

Excellent work Leandro

Greetings, from somewhere in Lima / Peru

[Albertomi]

Very valuable control, very useful.

Excellent work Leandro

Greetings, from somewhere in Lima / Peru

[gibra]

Hi Leandro, great work (as ever). I tried to compile the Menu con LabelPlus project but I get a error:

Compileation error
Unable to find Method or member data

on line:

LabelPlus1.PictureFromStream ReadFile(sFile)

of file: PropPagLP.pag

in this routine:

Private Sub cmdBrowse_Click()
    Dim sFile       As String
    Dim svName()    As String
    
    If VBGetOpenFileName(sFile, Filter:=FILTER_PICTURES, Owner:=PropertyPage.hwnd) Then


        Changed = True
        
        LabelPlus1.PictureFromStream ReadFile(sFile)
        If LabelPlus1.PictureExist Then
            CmdDelete.Enabled = True
        End If
    End If
End Sub

P.S.
Also ucNavBar project contains error when is load.

[yokesee]

great job.
Super they look so pretty.

in the example "Menu with LabelPlus"
could do the sub menus.
and also that could add so dynamic.


a genius greeting

[fafalone]

Wow fantastic work Leandro

[LeandroA]

hi Gibra i can't reproduce or find its error, maybe the property page doesn't charge the control?, the property page must have a LabelPlus1 control.
I admit that I still have several points to see, for example the ReadFile function is not unicode , but I don't think this is your problem to compile
on the other hand PD_icons.RES is poorly formed and I still can't find the solution, there is something that escapes my knowledge.

Does anyone else have trouble compiling?

[wqweto]

Here is some sample code for hot-tracking without timers loosly based on Implementing Hot Tracking in an ActiveX control article.

Place a Label1 on a new windowless user-control and try this code:

Option Explicit
 
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
 
Private m_bDown                 As Boolean
 
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    m_bDown = True
    UserControl_MouseMove Button, Shift, X, Y
End Sub
 
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    m_bDown = False
    UserControl_MouseMove Button, Shift, X, Y
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    UserControl_MouseMove Button, Shift, Label1.Left + X, Label1.Top + Y
End Sub
 
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo EH
    If X >= 0 And X <= ScaleWidth And Y >= 0 And Y <= ScaleHeight Then
        Label1.Caption = IIf(m_bDown, "Down", "Hot")
    Else
        Label1.Caption = IIf(m_bDown, "Down Outside", "Normal")
    End If
    If X >= 0 And X <= ScaleWidth And Y >= 0 And Y <= ScaleHeight Or m_bDown <> 0 Then
        If Not pvGetCapture() Then
            pvSetCapture True
        End If
    Else
        If pvGetCapture() Then
            pvSetCapture False
        End If
    End If
    Exit Sub
EH:
    Debug.Print "UserControl_MouseMove "; Err.Description; Err.Source
End Sub
 
Private Function pvGetCapture() As Boolean
    Const IDX_GetCapture As Long = 19
 
    If UserControl.hWnd = 0 Then
        If DispCallByVtbl(GetInPlaceSiteWindowless(Me), IDX_GetCapture) = 0 Then ' S_OK
            pvGetCapture = True
        End If
    ElseIf GetCapture() = UserControl.hWnd Then
        pvGetCapture = True
    End If
End Function
 
Private Sub pvSetCapture(ByVal bValue As Boolean)
    Const IDX_SetCapture As Long = 20
    
    If UserControl.hWnd = 0 Then
        DispCallByVtbl GetInPlaceSiteWindowless(Me), IDX_SetCapture, CLng(-bValue)
    Else
        If bValue Then
            Call SetCapture(UserControl.hWnd)
        Else
            Call ReleaseCapture
        End If
    End If
End Sub
 
Private Function GetInPlaceSiteWindowless(pCtl As IUnknown) As IUnknown
    Const E_NOINTERFACE As Long = &H80004002
    Const IDX_QueryInterface As Long = 0
    Const IDX_GetClientSite As Long = 4
    Dim aGuid(0 To 3)   As Long
    Dim pOleObject      As IUnknown
    Dim pOleClientSite  As IUnknown
    Dim hResult         As Long
    
    aGuid(0) = &H112: aGuid(2) = &HC0: aGuid(3) = &H46000000 ' IID_IOleObject
    hResult = DispCallByVtbl(pCtl, IDX_QueryInterface, VarPtr(aGuid(0)), VarPtr(pOleObject))
    If hResult < 0 Or pOleObject Is Nothing Then
        Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IUnknown.QueryInterface(IID_IOleObject)"
    End If
    hResult = DispCallByVtbl(pOleObject, IDX_GetClientSite, VarPtr(pOleClientSite))
    If hResult < 0 Or pOleClientSite Is Nothing Then
        Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IOleObject.GetClientSite"
    End If
    aGuid(0) = &H922EADA0: aGuid(1) = &H11CF3424  ' IID_IOleInPlaceSiteWindowless
    aGuid(2) = &HAA0070B6: aGuid(3) = &HD8D64C00
    hResult = DispCallByVtbl(pOleClientSite, IDX_QueryInterface, VarPtr(aGuid(0)), VarPtr(GetInPlaceSiteWindowless))
    If hResult < 0 Or GetInPlaceSiteWindowless Is Nothing Then
        Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IUnknown.QueryInterface(IID_IOleInPlaceSiteWindowless)"
    End If
End Function
 
Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    Const CC_STDCALL    As Long = 4
    Dim lIdx            As Long
    Dim vParam()        As Variant
    Dim vType(0 To 63)  As Integer
    Dim vPtr(0 To 63)   As Long
    Dim hResult         As Long
    
    vParam = A
    For lIdx = 0 To UBound(vParam)
        vType(lIdx) = VarType(vParam(lIdx))
        vPtr(lIdx) = VarPtr(vParam(lIdx))
    Next
    hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    If hResult < 0 Then
        Err.Raise hResult, "DispCallFunc"
    End If
End Function

The idea is to use SetCapture on the IOleInPlaceSiteWindowless to keep MouseMove events coming even when the pointer goes outside the user-control's bounds.

The meat of the code is in GetInPlaceSiteWindowless function which is using the recently somewhat popular DispCallByVtbl helper function.

cheers,
</wqw>

[gibra]

hi Gibra i can't reproduce or find its errorDoes anyone else have trouble compiling?

I discovered the cause:
because all the projects have the same name (Proyecto1), and in the Property page the LabelPlus1 object refere to the Proyecto1 name,
when I change the name project of sample, i.e. Proyecto1 to MenuLabelPlus, the name change on the Property page (file) also.
Therefore, when I running another project, the previous project name Proyecto1 is not recognized.

Solution:
So I create a copy of the common files:
PD_icons.RES, LabelPlus.ctl, LabelPlus.ctx, PropPagLP.pag and PropPagLP.pgx
in the project folder, then update the project Name with 'new' current project name.

[ChenLin]

Amazing and incredible! Expect to release vb.net version in the future!

The login example icon is not displayed clearly.

[LeandroA]

Hi wqweto, very interesting routine, unfortunately it would not be effective with this control since if a label is inside the other one, the one inside it does not receive the mouse enter event.
Already in the next version I am implementing MouseOver and MouseOut (they are different from MouseEnter and MouseLeave)
Thank you for your contribution

[LeandroA]

@ChenLin surely its DPI is greater than 100, so I recommend that you compile the project and execute it so you will notice it correctly.

[Eduardo-]

Thank you very much Leandro, I think I will use it.

[Hosam AL Dein]

Absolutely fabulous ,

I am big fan of firenze label and yes it had some limitations . Most of them are eliminated here . One of them was how it implemented mouse enter and exit events . So , I second weqweto`s suggestion .

[ChenLin]

@ChenLin surely its DPI is greater than 100, so I recommend that you compile the project and execute it so you will notice it correctly.

Make sure the DPI is 100. I tested it on all three computers. The operating system distribution is windows server, windows7, windows 10, and all of them are compiled and tested.

[Eduardo-]

Hello, JFY I tested here at 125% (120 DPI) on Windows 10 v1909 and it looked OK, no problem.
I tested it in the IDE and it is manifested for common controls and DPI aware.

[xxdoc123]

@ChenLin surely its DPI is greater than 100, so I recommend that you compile the project and execute it so you will notice it correctly.

i have the same question..

can set picturesetwidth=32 may be show completely.

picture can not stretch.may you can add this function....

[ChenLin]

i have the same question..

can set picturesetwidth=32 may be show completely.

picture can not stretch.may you can add this function....

Thank you @ xxdoc123, I tested your method and it works, as long as it is set to more than 20.

[shagratt]

Excellent control Leandro! Keep up the good work!
Love the blur effect.

[shagratt]

Hi Leandro! I'm wondering... In DrawAcrylicBlur(...) you call "GdipCreateEffect(&H633C80A4, &H482B1843, &H28BEF29E, &HD4FDC534, lEffect)" , but at the end there is no call to "GdipDeleteEffect(lEffect)". Could it be a leak of a GDI object or it is intended?

[LeandroA]

Hi Leandro! I'm wondering... In DrawAcrylicBlur(...) you call "GdipCreateEffect(&H633C80A4, &H482B1843, &H28BEF29E, &HD4FDC534, lEffect)" , but at the end there is no call to "GdipDeleteEffect(lEffect)". Could it be a leak of a GDI object or it is intended?

Ups! very true, I forgot that detail, thanks for advising.

[shagratt]

Ups! very true, I forgot that detail, thanks for advising.

Still leaking...mmm... its also missing "Call GdipDisposeImage(hImage)" ! Almost missed that one.
In the end I changed it to:

        'Cleanup
        Call GdipDeleteBrush(hBrush)
        Call GdipDeleteGraphics(hGraphics2)
        Call GdipDisposeImage(hImage)
        Call GdipDisposeImage(hImage2)
        Call GdipDeleteEffect(lEffect)

[AAraya]

Looks very useful! Is there any documentation other than the included samples?

[Black_Storm]

when i want open samples use projects i can see just this error : "expersion too complex" how can open projects without this error.because i can open projects now.



or

[cliv]

Unicode caption in IDE - property pages like TextBoxW from Krools Common Controls, can be implemented?

[LeandroA]

Unicode caption in IDE - property pages like TextBoxW from Krools Common Controls, can be implemented?

Hi Cliv, I think I did not understand the question correctly, but if you refer to putting a unicode text at design time you can do it through the properties page, as I did not want to subclassify I put a button to the right of the text box to input , that text box is unicode.

[cliv]

I think I did not understand the question correctly.

yes, i mean input unicode in the IDE using properties page ... but i am not able to input romanian characters in a English OS directly from keyboard (with ROU keyboard layout selected)



...thank you for support

[LeandroA]

yes, i mean input unicode in the IDE using properties page ... but i am not able to input romanian characters in a English OS directly from keyboard (with ROU keyboard layout selected)



...thank you for support

ok now I understand, but I don't know what the reason is, that is where my knowledge goes, I'm not sure if it's because of the input method or GDI +, maybe someone can provide some information

[cliv]

OS: Windows 10 Pro Version 1903 - x64, language: english, keyboard: english(US keyboard), romanian(standard keyboard).
Switch keyboard layout to ROU and input unicode in the IDE using properties page:

1. LabelPlus - not working (direct type in IDE properties page)
2. LabelPlus - working (paste from clipboard - input unicode in Notepad and then copy to clipboard)
3. TextBoxW (Krools Common Controls) - working (direct type in IDE properties page)
4. UniSuiteFree (Textbox, Label, ...) Dana Seaman - CyberActiveX - working (direct type in IDE properties page)

[Arnoutdv]

I never understood why people insist to use the property window to set captions or whatever.
Just set the correct value in the Form_Load

[mirzaasif4249]

I am a newbie and want to know to open another form with the click event of ucNavBar. Attachment 180400

[cliv]

1. LabelPlus - not working (direct type in IDE properties page)

People are all stressed about the PropertyBag not supporting Unicode, but that's not a problem. There is a problem with the actual properties window. That does NOT support Unicode, but if you're willing to build your own properties window (which can be done in VB6), you can circumvent that problem too. However, back to the PropertyBag. The problem is that .FRM files are written out in ANSI (which can't do Unicode), and the PropertyBag must be written out to these .FRM files. But there's also the .FRX files. Any binary stuff or non-ANSI stuff (including Unicode) is written into these .FRX files. Therefore, any Unicode fields we have in our custom controls must be coerced into these .FRX files and not the ANSI .FRM file. Here are two procedures for assisting with that. Just use them to go back and forth before writing your strings into the PropertyBag and everything will work. When you hit "save" that field of the PropertyBag will be written into the .FRX rather than the .FRM

From here ...
https://www.vbforums.com/showthread....=1#post4719635

[AAraya]

Wow - what an impressive user control this seems to be. Working my way through the demo projects right now.

Only thing missing is user documentation - that would make this perfection! Thanks Leandro!

[AAraya]

I've been able to create a Chip UI component using this excellent control. One thing I can't figure out however is how to set a Picture for a label. I see many Picture related properties on the label's Property Page.



And in the AVG demo, I can see that LabelPlus13 has a picture set via the Custom property on the Property Page. But my labels don't have a Custom property...

What am I missing? I'm looking for a simple .Picture property which can be set at design or runtime.

Thanks in advance for any assistance you can provide.

@LeandroA

[zx81sp]

Probably you forgot to add the properties page to your project, just only the control, take a look to that.

[AAraya]

Probably you forgot to add the properties page to your project, just only the control, take a look to that.

Thanks for your help with this. When I add the Property Page (PropPagLP.pag) from the demo into my project, I get a "Method or Data Member not found" error in the Property Page's cmdBrowse_Click code for this method "LabelPlus1.PictureFromStream" and several entries in a LOG file which is created.

Attachment 190721


Line 64: Class Proyecto1.LabelPlus of control LabelPlus1 was not a loaded control class.
Line 70: The property name _ExtentX in LabelPlus1 is invalid.
Line 71: The property name _ExtentY in LabelPlus1 is invalid.
Line 72: The property name BorderCornerLeftTop in LabelPlus1 is invalid.
Line 73: The property name BorderCornerRightTop in LabelPlus1 is invalid.
Line 74: The property name BorderCornerBottomRight in LabelPlus1 is invalid.
Line 75: The property name BorderCornerBottomLeft in LabelPlus1 is invalid.
Line 76: The property name Caption in LabelPlus1 is invalid.
Line 77: The property name CaptionBorderColor in LabelPlus1 is invalid.
Line 87: The property name ShadowColorOpacity in LabelPlus1 is invalid.
Line 88: The property name CallOutAlign in LabelPlus1 is invalid.
Line 89: The property name CallOutWidth in LabelPlus1 is invalid.
Line 90: The property name CallOutLen in LabelPlus1 is invalid.
Line 92: The property name PictureArr in LabelPlus1 is invalid.

[AAraya]

I have resolved the issue I was having with the Property Page.

I had copied the Property Page from his demo project into my project folder. When I examined the property page in a text editor I saw that the definition for the LabelPlus1 control on the Property Page included his demo project name like this:
"Begin Proyecto1.LabelPlus LabelPlus1".

I simply had to change his project name to the name of my project.

Probably a rookie mistake but I've never encountered this before.

[zx81sp]

I have resolved the issue I was having with the Property Page.

I had copied the Property Page from his demo project into my project folder. When I examined the property page in a text editor I saw that the definition for the LabelPlus1 control on the Property Page included his demo project name like this:
"Begin Proyecto1.LabelPlus LabelPlus1".

I simply had to change his project name to the name of my project.

Probably a rookie mistake but I've never encountered this before.

Some of Leandro's controls are attached to the name "proyecto1" and must be adapted to your project name but it worths because his controls are unbeilable.

[AAraya]

Some of Leandro's controls are attached to the name "proyecto1" and must be adapted to your project name but it worths because his controls are unbeilable.

Yes, his user controls are wonderful! The only oddity I've found is why I can't just simply set a .Picture() property on the user control at runtime. If I could do this, they would be perfect!

[AngelV]

Here is some sample code for hot-tracking without timers loosly based on Implementing Hot Tracking in an ActiveX control article.

Place a Label1 on a new windowless user-control and try this code:

Option Explicit
 
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
 
Private m_bDown                 As Boolean
 
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    m_bDown = True
    UserControl_MouseMove Button, Shift, X, Y
End Sub
 
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    m_bDown = False
    UserControl_MouseMove Button, Shift, X, Y
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    UserControl_MouseMove Button, Shift, Label1.Left + X, Label1.Top + Y
End Sub
 
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo EH
    If X >= 0 And X <= ScaleWidth And Y >= 0 And Y <= ScaleHeight Then
        Label1.Caption = IIf(m_bDown, "Down", "Hot")
    Else
        Label1.Caption = IIf(m_bDown, "Down Outside", "Normal")
    End If
    If X >= 0 And X <= ScaleWidth And Y >= 0 And Y <= ScaleHeight Or m_bDown <> 0 Then
        If Not pvGetCapture() Then
            pvSetCapture True
        End If
    Else
        If pvGetCapture() Then
            pvSetCapture False
        End If
    End If
    Exit Sub
EH:
    Debug.Print "UserControl_MouseMove "; Err.Description; Err.Source
End Sub
 
Private Function pvGetCapture() As Boolean
    Const IDX_GetCapture As Long = 19
 
    If UserControl.hWnd = 0 Then
        If DispCallByVtbl(GetInPlaceSiteWindowless(Me), IDX_GetCapture) = 0 Then ' S_OK
            pvGetCapture = True
        End If
    ElseIf GetCapture() = UserControl.hWnd Then
        pvGetCapture = True
    End If
End Function
 
Private Sub pvSetCapture(ByVal bValue As Boolean)
    Const IDX_SetCapture As Long = 20
    
    If UserControl.hWnd = 0 Then
        DispCallByVtbl GetInPlaceSiteWindowless(Me), IDX_SetCapture, CLng(-bValue)
    Else
        If bValue Then
            Call SetCapture(UserControl.hWnd)
        Else
            Call ReleaseCapture
        End If
    End If
End Sub
 
Private Function GetInPlaceSiteWindowless(pCtl As IUnknown) As IUnknown
    Const E_NOINTERFACE As Long = &H80004002
    Const IDX_QueryInterface As Long = 0
    Const IDX_GetClientSite As Long = 4
    Dim aGuid(0 To 3)   As Long
    Dim pOleObject      As IUnknown
    Dim pOleClientSite  As IUnknown
    Dim hResult         As Long
    
    aGuid(0) = &H112: aGuid(2) = &HC0: aGuid(3) = &H46000000 ' IID_IOleObject
    hResult = DispCallByVtbl(pCtl, IDX_QueryInterface, VarPtr(aGuid(0)), VarPtr(pOleObject))
    If hResult < 0 Or pOleObject Is Nothing Then
        Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IUnknown.QueryInterface(IID_IOleObject)"
    End If
    hResult = DispCallByVtbl(pOleObject, IDX_GetClientSite, VarPtr(pOleClientSite))
    If hResult < 0 Or pOleClientSite Is Nothing Then
        Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IOleObject.GetClientSite"
    End If
    aGuid(0) = &H922EADA0: aGuid(1) = &H11CF3424  ' IID_IOleInPlaceSiteWindowless
    aGuid(2) = &HAA0070B6: aGuid(3) = &HD8D64C00
    hResult = DispCallByVtbl(pOleClientSite, IDX_QueryInterface, VarPtr(aGuid(0)), VarPtr(GetInPlaceSiteWindowless))
    If hResult < 0 Or GetInPlaceSiteWindowless Is Nothing Then
        Err.Raise IIf(hResult < 0, hResult, E_NOINTERFACE), "IUnknown.QueryInterface(IID_IOleInPlaceSiteWindowless)"
    End If
End Function
 
Private Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    Const CC_STDCALL    As Long = 4
    Dim lIdx            As Long
    Dim vParam()        As Variant
    Dim vType(0 To 63)  As Integer
    Dim vPtr(0 To 63)   As Long
    Dim hResult         As Long
    
    vParam = A
    For lIdx = 0 To UBound(vParam)
        vType(lIdx) = VarType(vParam(lIdx))
        vPtr(lIdx) = VarPtr(vParam(lIdx))
    Next
    hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    If hResult < 0 Then
        Err.Raise hResult, "DispCallFunc"
    End If
End Function

The idea is to use SetCapture on the IOleInPlaceSiteWindowless to keep MouseMove events coming even when the pointer goes outside the user-control's bounds.

The meat of the code is in GetInPlaceSiteWindowless function which is using the recently somewhat popular DispCallByVtbl helper function.

cheers,
</wqw>

@wqweto

The idea is to use SetCapture on the IOleInPlaceSiteWindowless to keep MouseMove events coming even when the pointer goes outside the user-control's bounds.

Could you elaborate on this ? Does this method still rely on the label being above the windowless control while leaving some space between the bounding rect of the label and the bounding rectangle of the windowless control?

Thanks.