how to transparency Button like Listbox by vb6?

**xiaoyao** · Apr 5th, 2021, 06:19 AM

.net framework,it's cool

https://www.vbforums.com/showthread....r-a-picturebox

Code:

Option Explicit
 
Private Declare Function ReleaseCapture Lib "user32" () 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 Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
 
 
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Const TRANSPARENT           As Long = 1
Private Const WM_CTLCOLORLISTBOX    As Long = &H134
Private Const WM_CTLCOLORSTATIC     As Long = &H138
Private Const WM_VSCROLL            As Long = &H115
 
Dim WithEvents WndProc  As clsTrickSubclass ' Объект для сабклассинга формы
Dim WithEvents lstProc  As clsTrickSubclass ' Объект для сабклассинга списка
 
Dim hBackBrush  As Long ' Фоновая кисть
 Private Sub list1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then

    Call ReleaseCapture
    SendMessage List1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    List1.Refresh
End If
End Sub

Private Sub Form_Load()
'Set a larger background image test.jpg for the form, and move the text box to see the transparency effect
    Me.Picture = LoadPicture(App.Path & "\test.jpg")


    ' Создаем кисть для отрисовки фона на основе фонового изображения формы
    hBackBrush = CreatePatternBrush(Me.Picture.Handle)
    ' Сабклассинг формы
    Set WndProc = New clsTrickSubclass
    Set lstProc = New clsTrickSubclass
    
    WndProc.Hook Me.hwnd
    lstProc.Hook List1.hwnd
    
    ' Добавляем в список тестовые значения
    Do While List1.ListCount < 100
        List1.AddItem Format(List1.ListCount, "ITE\M 00")
    Loop
    
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    ' Удаляем кисть
    DeleteObject hBackBrush
End Sub
 
' Оконная процедура списка
Private Sub lstProc_wndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Select Case Msg
    ' При прокрутке списка
    Case WM_VSCROLL
        ' Объявляем всю область списка недействительной и требующей перерисовки
        InvalidateRect hwnd, ByVal 0&, 0
    End Select
    ' Вызов по умолчанию
    DefCall = True
    
End Sub
 
' Оконная процедура формы
Private Sub wndProc_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Select Case Msg
    ' При запросе кисти фона списка или слайдера
    Case WM_CTLCOLORSTATIC, WM_CTLCOLORLISTBOX
        Dim pts(1)  As Long
        ' Получаем координаты элемента
        MapWindowPoints lParam, Me.hwnd, pts(0), 1
        ' Сдвигаем точку отсчета координат кисти, чтобы она совпадала с фоновом изображением под контролом
        SetBrushOrgEx wParam, -pts(0), -pts(1), ByVal 0&
        ' Если это список
        If lParam = List1.hwnd Then
            ' Устанавливаем прозрачный фон для текста
            SetBkMode wParam, TRANSPARENT
            ' Устанавливаем цвет текста
            SetTextColor wParam, vbWhite
        
        End If
        ' Возвращаем кисть
        Ret = hBackBrush
        
    Case Else:  DefCall = True  ' Остальное оставляем без изменений
    End Select
    
End Sub

clsTrickSubclass.cls
https://www.vbforums.com/showthread....sTrickSubclass
https://www.vbforums.com/attachment....1&d=1423662614

by vb.net

Code:

Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Me.EmbedButtonInPictureBox(Me.Button1, Me.PictureBox1)
Me.EmbedButtonInPictureBox(Me.Button2, Me.PictureBox1)
Me.EmbedButtonInPictureBox(Me.Button3, Me.PictureBox1)
End Sub
 
Private Sub EmbedButtonInPictureBox(ByVal btn As Button, ByVal pbx As PictureBox)
Dim buttonLocation As Point = pbx.PointToClient(Me.PointToScreen(btn.Location))
 
btn.Parent = pbx
btn.Location = buttonLocation
 
Dim buttonBackground As New Bitmap(btn.Width, btn.Height)
 
Using g As Graphics = Graphics.FromImage(buttonBackground)
g.DrawImage(pbx.Image, _
New Rectangle(0, _
                                  0, _
buttonBackground.Width, _
buttonBackground.Height), _
btn.Bounds, _
GraphicsUnit.Pixel)
End Using
 
btn.BackgroundImage = buttonBackground
End Sub

**yokesee** · Apr 5th, 2021, 09:27 AM

good contribution.
With the mouse wheel it works badly.

regards

**hwoarang** · Apr 5th, 2021, 12:47 PM

Originally Posted by xiaoyao

Code:

Option Explicit
 
Private Declare Function ReleaseCapture Lib "user32" () 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 Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
 
 
 
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Const TRANSPARENT           As Long = 1
Private Const WM_CTLCOLORLISTBOX    As Long = &H134
Private Const WM_CTLCOLORSTATIC     As Long = &H138
Private Const WM_VSCROLL            As Long = &H115
 
Dim WithEvents WndProc  As clsTrickSubclass ' Объект для сабклассинга формы
Dim WithEvents lstProc  As clsTrickSubclass ' Объект для сабклассинга списка
 
Dim hBackBrush  As Long ' Фоновая кисть
 Private Sub list1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then

    Call ReleaseCapture
    SendMessage List1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    List1.Refresh
End If
End Sub

Private Sub Form_Load()
'Set a larger background image test.jpg for the form, and move the text box to see the transparency effect
    Me.Picture = LoadPicture(App.Path & "\test.jpg")


    ' Создаем кисть для отрисовки фона на основе фонового изображения формы
    hBackBrush = CreatePatternBrush(Me.Picture.Handle)
    ' Сабклассинг формы
    Set WndProc = New clsTrickSubclass
    Set lstProc = New clsTrickSubclass
    
    WndProc.Hook Me.hwnd
    lstProc.Hook List1.hwnd
    
    ' Добавляем в список тестовые значения
    Do While List1.ListCount < 100
        List1.AddItem Format(List1.ListCount, "ITE\M 00")
    Loop
    
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    ' Удаляем кисть
    DeleteObject hBackBrush
End Sub
 
' Оконная процедура списка
Private Sub lstProc_wndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Select Case Msg
    ' При прокрутке списка
    Case WM_VSCROLL
        ' Объявляем всю область списка недействительной и требующей перерисовки
        InvalidateRect hwnd, ByVal 0&, 0
    End Select
    ' Вызов по умолчанию
    DefCall = True
    
End Sub
 
' Оконная процедура формы
Private Sub wndProc_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
    
    Select Case Msg
    ' При запросе кисти фона списка или слайдера
    Case WM_CTLCOLORSTATIC, WM_CTLCOLORLISTBOX
        Dim pts(1)  As Long
        ' Получаем координаты элемента
        MapWindowPoints lParam, Me.hwnd, pts(0), 1
        ' Сдвигаем точку отсчета координат кисти, чтобы она совпадала с фоновом изображением под контролом
        SetBrushOrgEx wParam, -pts(0), -pts(1), ByVal 0&
        ' Если это список
        If lParam = List1.hwnd Then
            ' Устанавливаем прозрачный фон для текста
            SetBkMode wParam, TRANSPARENT
            ' Устанавливаем цвет текста
            SetTextColor wParam, vbWhite
        
        End If
        ' Возвращаем кисть
        Ret = hBackBrush
        
    Case Else:  DefCall = True  ' Остальное оставляем без изменений
    End Select
    
End Sub

It is reasonable to translate comments in code into English. I am a native russian speaker too, but if you do share your code in community - try your best to make everything "english-compatible".
Moreover - what is "clsTrickSubclass" ? Where is the code of it?

Btw, here is a proper way to subclass almost safe - https://bitbucket.org/hwoarang84/vbc...r/Subclass.bas. Original code is not mine (can't find source and author), but I made few adjustments and bugfixes.

**The trick** · Apr 5th, 2021, 01:31 PM

This is the original code. Transparent buttons. OwnerDraw buttons.

**xiaoyao** · Apr 5th, 2021, 07:00 PM

If the form has a background image, place a text box or list box on it, along with a picture box control. You can use a variety of different methods to achieve a more perfect transparency effect.
But if the controls overlap. The transparency becomes just for the background image. It does not see the controls below it.In fact, each of the different up and down order of the control, it corresponds to the background image is to make up their own.
If there is a label control behind the list box, the data is updated three times per second. Then we need to take a screenshot of all the controls behind the list box.The most efficient way to do this is to take only the portion of the text that changes and superimpose it on the background image handle of the text box.

You might hook the GDI function (GDI _ DraWtext).I feel that VB.NET is not dealing with real transparency.

**xiaoyao** · Apr 5th, 2021, 07:16 PM

Originally Posted by The trick

This is the original code. Transparent buttons. OwnerDraw buttons.

i have a test, The button is not really transparent, once clicked, the picture on the button disappears

Thread: how to transparency Button like Listbox by vb6?

Thread Tools

Display

how to transparency Button like Listbox by vb6?

Re: how to transparency Button like Listbox by vb6?

Re: how to transparency Button like Listbox by vb6?

Re: how to transparency Button like Listbox by vb6?

Re: how to transparency Button like Listbox by vb6?

Re: how to transparency Button like Listbox by vb6?

Posting Permissions