Results 1 to 11 of 11

Thread: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    How to use API to set text to transparent and accept cursor in vb

    sample 1:Transparent Textbox-01.zip
    sample 2:
    Code:
    '在窗体Form代码中,把以下代码复制进去:
    'IN FORM1
    Private Sub Form_Load()
    makeTransparentTextbox Text1 'Text1
    '是需要透明的文本框
    End Sub

    'BAS FILE: APIs to install our subclassing routines
    Code:
    Private Const GWL_WNDPROC = (-4)
    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 Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' These APIs are used to create a pattern brush for each textbox...
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    ' Messages which we will be processing in our subclassing routines
    Private Const WM_COMMAND As Long = &H111
    Private Const WM_CTLCOLOREDIT As Long = &H133
    Private Const WM_DESTROY As Long = &H2
    Private Const WM_ERASEBKGND As Long = &H14
    Private Const WM_HSCROLL As Long = &H114
    Private Const WM_VSCROLL As Long = &H115
    ' A rectangle.
    Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type
    ' APIs used to keep track of brush handles and process addresses
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    ' APIs used in our subclassing routine to create the "transparent" effect.
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function WindowFromDC Lib "user32" (ByVal hdc As Long) As Long
    Public Function makeTransparentTextbox(aTxt As TextBox)
    ' Make sure we don't have any typos in our subclassing procedures.
    NewWindowProc 0, 0, 0, 0
    NewTxtBoxProc 0, 0, 0, 0
    ' Create a background brush for this textbox, which we will used to give
    ' the textbox an APPEARANCE of transparency
    CreateBGBrush aTxt
    ' Subclass the textbox's form, IF NOT ALREADY subclassed
    If GetProp(GetParent(aTxt.hwnd), "OrigProcAddr") = 0 Then
    SetProp GetParent(aTxt.hwnd), "OrigProcAddr", SetWindowLong(GetParent(aTxt.hwnd), GWL_WNDPROC, AddressOf NewWindowProc)
    End If
    ' Subclass the textbox, IF NOT ALREADY subclassed
    If GetProp(aTxt.hwnd, "OrigProcAddr") = 0 Then
    SetProp aTxt.hwnd, "OrigProcAddr", SetWindowLong(aTxt.hwnd, GWL_WNDPROC, AddressOf NewTxtBoxProc)
    End If
    End Function
    Private Sub CreateBGBrush(aTxtBox As TextBox)
    Dim screenDC As Long ' The screen's device context.
    Dim imgLeft As Long ' The X location inside the image which we are going to copy from.
    Dim imgTop As Long ' The Y location inside the image which we are going to copy from.
    Dim picDC As Long ' A temporary DC to pull the form's picture into
    Dim picBmp As Long ' the 1x1 bitmap which is created with picDC
    Dim aTempBmp As Long ' A temporary bitmap we'll use to create the pattern brush for our textbox
    Dim aTempDC As Long ' the temporary device context used to hold aTempBmp
    Dim txtWid As Long ' The form's width
    Dim txtHgt As Long ' the form's height.
    Dim solidBrush As Long ' Solid brush used to color in the bitmap... incase the textbox
    ' gets sized outside the dimensions of the picture
    Dim aRect As RECT ' Rectangle to fill in with solid brush
    If aTxtBox.Parent.Picture Is Nothing Then Exit Sub
    ' Get our form's dimensions, in pixels
    txtWid = aTxtBox.Width / Screen.TwipsPerPixelX
    txtHgt = aTxtBox.Height / Screen.TwipsPerPixelY
    ' Get the location within the bitmap picture we're copying from
    imgLeft = aTxtBox.Left / Screen.TwipsPerPixelX
    imgTop = aTxtBox.Top / Screen.TwipsPerPixelY
    ' Get the screen's device context
    screenDC = GetDC(0)
    ' Create a device context to hold the form's picture.
    picDC = CreateCompatibleDC(screenDC)
    picBmp = SelectObject(picDC, aTxtBox.Parent.Picture.Handle)
    ' Create a temporary bitmap to blt the underlying image onto
    aTempDC = CreateCompatibleDC(screenDC)
    aTempBmp = CreateCompatibleBitmap(screenDC, txtWid, txtHgt)
    DeleteObject SelectObject(aTempDC, aTempBmp)
    ' create a brush the color of BUTTON_FACE
    solidBrush = CreateSolidBrush(GetSysColor(15))
    aRect.Right = txtWid
    aRect.Bottom = txtHgt
    ' Fill in the area
    FillRect aTempDC, aRect, solidBrush
    ' clean up our resource
    DeleteObject solidBrush
    ' Transfer the image
    BitBlt aTempDC, 0, 0, txtWid, txtHgt, picDC, imgLeft, imgTop, vbSrcCopy
    ' Check to make sure that a brush hasn't already been made for this one
    If GetProp(aTxtBox.hwnd, "CustomBGBrush") <> 0 Then
    ' If so, then delete it and free its memory before storing the new one's handle.
    DeleteObject GetProp(aTxtBox.hwnd, "CustomBGBrush")
    End If
    ' Create a pattern brush from our bitmap and store its handle against
    ' the textbox's handle
    SetProp aTxtBox.hwnd, "CustomBGBrush", CreatePatternBrush(aTempBmp)
    ' Clean up our temporary DC and bitmap resources
    DeleteDC aTempDC
    DeleteObject aTempBmp
    ' Replace the original 1x1 bitmap, releasing the form's picture
    SelectObject picDC, picBmp
    ' Clean up our picture DC and the 1x1 bitmap that was created with it
    DeleteDC picDC
    DeleteObject picBmp
    ' Release the screen's DC back to the system... forgetting to do this
    ' causes a nasty memory leak.
    ReleaseDC 0, screenDC
    End Sub
    Private Function NewWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' ******************************************************
    ' SUBCLASSING ROUTINE FOR THE TEXTBOX'S >>>>PARENT<<<<
    ' ******************************************************
    Dim origProc As Long ' The original process address for the window.
    Dim isSubclassed As Long ' Whether a certain textbox is subclassed or not.
    ' I've gotten in the habit of passing 0 values to the subclassing functions before
    ' actually installing them, just to make sure that I don't have any typos or other
    ' problems which can be easily detected. As such, if there is a hwnd of 0, its not
    ' a "valid" message, so we'll just exit right away.
    If hwnd = 0 Then Exit Function
    ' Get the original process address which we stored earlier.
    origProc = GetProp(hwnd, "OrigProcAddr")
    If origProc <> 0 Then
    If (uMsg = WM_CTLCOLOREDIT) Then
    ' Check to see if our window has a stored value for the original
    ' process address. If so, we're subclassing this one.
    isSubclassed = (GetProp(WindowFromDC(wParam), "OrigProcAddr") <> 0)
    If isSubclassed Then
    ' Invoke the default process... This will set the font, font color
    ' and other stuff we don't really want to fool with.
    CallWindowProc origProc, hwnd, uMsg, wParam, lParam
    ' Make the words print transparently
    SetBkMode wParam, 1
    ' Return the handle to our custom brush rather than that which
    ' the default process would have returned.
    NewWindowProc = GetProp(WindowFromDC(wParam), "CustomBGBrush")
    Else
    ' The textbox in question isn't subclassed, so we aren't going
    ' to do anything out of the ordinary. Just invoke the default proc.
    NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    End If
    ElseIf uMsg = WM_COMMAND Then
    ' Check to see if our window has a stored value for the original
    ' process address. If so, we're subclassing this one.
    isSubclassed = (GetProp(lParam, "OrigProcAddr") <> 0)
    If isSubclassed Then
    ' We are going lock the window from updating while we invalidate
    ' and redraw it. This prevents flickering.
    LockWindowUpdate GetParent(lParam)
    ' Force windows to redraw the window.
    InvalidateRect lParam, 0&, 1&
    UpdateWindow lParam
    End If
    ' Invoke the default process
    NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    If isSubclassed Then LockWindowUpdate 0&
    ElseIf uMsg = WM_DESTROY Then
    ' The window is being destroyed... time to unhook our process so we
    ' don't cause a big fat error which crashes the application.
    ' Install the default process address again
    SetWindowLong hwnd, GWL_WNDPROC, origProc
    ' Invoke the default process
    NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    ' Remove our stored value since we don't need it anymore
    RemoveProp hwnd, "OrigProcAddr"
    Else
    ' We're not concerned about this particular message, so we'll just
    ' let it go on its merry way.
    NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    End If
    Else
    ' A catch-all in case something freaky happens with the process addresses.
    NewWindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    End If
    End Function
    Private Function NewTxtBoxProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' *********************************************
    ' SUBCLASSING ROUTINE FOR THE >>>>TEXTBOX<<<<
    ' *********************************************
    Dim aRect As RECT
    Dim origProc As Long
    Dim aBrush As Long
    If hwnd = 0 Then Exit Function
    ' Get the original process address which we stored earlier.
    origProc = GetProp(hwnd, "OrigProcAddr")
    If origProc <> 0 Then
    ' We're subclassing! Which is silly, 'cause otherwise we wouldn't be in
    ' this function, however we double check the process address just in case.
    If uMsg = WM_ERASEBKGND Then
    ' We're going to get our custom brush for this textbox and fill the
    ' textbox's background area with it...
    aBrush = GetProp(hwnd, "CustomBGBrush")
    If aBrush <> 0 Then
    ' Get the area dimensions to fill
    GetClientRect hwnd, aRect
    ' Fill it with our custom brush
    FillRect wParam, aRect, aBrush
    ' Tell windows that we took care of the "erasing"
    NewTxtBoxProc = 1
    Else
    ' Something happened to our custom brush :-\ We'll just invoke
    ' the default process
    NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    End If
    ElseIf uMsg = WM_HSCROLL Or uMsg = WM_VSCROLL Then
    ' We are scrolling, either horizontally or vertically. This requires
    ' us to totally repaint the background area... so we'll lock the
    ' window updates so we don't see any of the freaky flickering
    LockWindowUpdate GetParent(hwnd)
    ' Invoke the default process so the user actually get's the scroll
    ' they want
    NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    ' Force window to repaint itself
    InvalidateRect hwnd, 0&, 1&
    UpdateWindow hwnd
    ' Release the update lock
    LockWindowUpdate 0&
    ElseIf uMsg = WM_DESTROY Then
    ' The textbox's parent is closing / destroying, so we need to
    ' unhook our subclassing routine ... or bad things happen
    ' Clean up our brush object... muy importante!!!
    aBrush = GetProp(hwnd, "CustomBGBrush")
    ' Delete the brush object, freeing its resource.
    DeleteObject aBrush
    ' Remove our values we stored against the textbox's handle
    RemoveProp hwnd, "OrigProcAddr"
    RemoveProp hwnd, "CustomBGBrush"
    ' Replace the original process address
    SetWindowLong hwnd, GWL_WNDPROC, origProc
    ' Invoke the default "destroy" process
    NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    Else
    ' We're not interested in this message, so we'll just let it truck
    ' right on thru... invoke the default process
    NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
    End If
    Else
    ' A catch-all in case something freaky happens with the process addresses.
    NewTxtBoxProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    End If
    End Function
    Attached Images Attached Images  
    Last edited by xiaoyao; Mar 29th, 2021 at 10:25 PM.

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    Code:
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        
    Private Const GWL_EXSTYLE = (-20)
    Private Const WS_EX_TRANSPARENT = &H20&
     
    Private Sub Form_Load()
        SetWindowLong RichTextBox1.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
    End Sub
    if move RichTextBox1,then background picture not true,how to do?

  3. #3

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    HOW TO USE THIS BY VB6?WHAT'S HBRUSH?

    Code:
     case CTLCOLOR_STATIC: //对所有静态文本控件的设置            
    
                  {                   
    pDC->SetBkMode(TRANSPARENT);//设置背景为透明  
      pDC->SetTextColor(RGB(0,0,0)); //设置字体颜色                  
    
    
    return HBRUSH(GetStockObject(HOLLOW_BRUSH)); //
    Code:
    Option Explicit
    
    Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
    Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetMenuInfo Lib "user32" (ByVal hMenu As Long, lpcmi As tagMENUINFO) As Long
    Private Declare Function SetMenuInfo Lib "user32" (ByVal hMenu As Long, lpcmi As tagMENUINFO) As Long
    
    Private Type LOGBRUSH
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
    End Type
    
    Private Type tagMENUINFO
        cbSize As Long
        fMask As Long
        dwStyle As Long
        cyMax As Long
        hbrBack As Long
        dwContextHelpID As Long
        dwMenuData As Long
    End Type
    
    Private Const BS_SOLID = 0
    Private Const MIM_APPLYTOSUBMENUS = &H80000000
    Private Const MIM_BACKGROUND = &H2
    
    Private Sub Form_Load()
        Dim ret As Long
        Dim hMenu As Long
        Dim hBrush As Long
        Dim lbBrushInfo As LOGBRUSH
        Dim miMenuInfo As tagMENUINFO
        
        lbBrushInfo.lbStyle = BS_SOLID
        lbBrushInfo.lbColor = RGB(155, 100, 200)
        lbBrushInfo.lbHatch = 0
        hBrush = CreateBrushIndirect(lbBrushInfo)
        
        hMenu = GetMenu(Me.hwnd)
        
        miMenuInfo.cbSize = Len(miMenuInfo)
        ret = GetMenuInfo(hMenu, miMenuInfo) ' 0 means failure
        
        miMenuInfo.fMask = MIM_BACKGROUND 'MIM_APPLYTOSUBMENUS  use this to apply to submenus as well
        miMenuInfo.hbrBack = hBrush
        ret = SetMenuInfo(hMenu, miMenuInfo) '0 means failure
    
    End Sub

  4. #4

  5. #5

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    This is exactly what I want, very powerful, very good, thank you very much.
    Using the same code, I failed the test for a day.
    For example, the use of shaping the color of the transparent window, how to achieve mouse penetration or not penetration.I tested a section of the code and others almost the same, and finally found that there are several different API.My code on the mouse can not click down, in the accident this is also a good function.

    Code:
    Option Explicit
     
    Private Type RECT
        iLeft As Long
        iTop As Long
        iRight As Long
        iBottom As Long
    End Type
     
    Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect 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 ExcludeClipRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
     
    Private Const GWL_EXSTYLE       As Long = (-20)
    Private Const WS_EX_TRANSPARENT As Long = &H20&
    Private Const NULL_BRUSH        As Long = 5
    Private Const TRANSPARENT       As Long = 1
    Private Const WM_NCHITTEST      As Long = &H84
    Private Const WM_CTLCOLOREDIT   As Long = &H133
    Private Const HTCAPTION         As Long = 2
    Private Const RDW_INVALIDATE    As Long = &H1
    Private Const RDW_UPDATENOW     As Long = &H100&
    Private Const RDW_ALLCHILDREN   As Long = &H80
     
    Dim WithEvents mSubclass    As clsTrickSubclass
    Dim mIsCancel   As Boolean
     
    Private Sub cmdCancel_Click()
        txtSrc.Text = vbNullString
        Unload Me
    End Sub
    Private Sub cmdOK_Click()
        Unload Me
    End Sub
     
    Private Sub Form_Load()
        ' Устанавливаем прозрачный фон для текстбокса
        SetWindowLong txtSrc.hwnd, GWL_EXSTYLE, GetWindowLong(txtSrc.hwnd, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
        Set mSubclass = New clsTrickSubclass
        ' Сабклассинг
        mSubclass.Hook Me.hwnd
    End Sub
     
    Private Sub Form_Unload(Cancel As Integer)
        mSubclass.UnHook
    End Sub
     
    Private Sub mSubclass_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_CTLCOLOREDIT
            Static RC       As RECT     ' Прямоугольник окна текстбокса
            Static isRedraw As Boolean  ' Флаг перерисовки родителя
            
            ' Если флаг перерисовки родителя не установлен, тогда перерисовываем фон под собой
            If Not isRedraw Then
                ' Проецируем координаты рабочей области на родителя
                GetClientRect lParam, RC
                MapWindowPoints lParam, hwnd, RC, 2
                ' Рисуем фон родителя под текстбоксом
                isRedraw = True
                RedrawWindow hwnd, RC, 0, RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_ALLCHILDREN
                isRedraw = False
                ' Исключаем всю область, т.к. предыдущий вызов уже отрисовал текст
                ExcludeClipRect wParam, 0, 0, RC.iRight, RC.iBottom
            End If
            
            ' Установка прозрачной кисти и типа фона текста
            SetBkMode wParam, TRANSPARENT
            Ret = GetStockObject(NULL_BRUSH)
            
        Case WM_NCHITTEST: Ret = HTCAPTION  ' Перетаскивание за любое место
        Case Else: DefCall = True           ' Все остальное - по умолчанию
        End Select
     
    End Sub

  6. #6

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    I also used this method in the end of the test, but it did not have any effect.(WS_EX_TRANSPARENT)。I'll try your code tomorrow.

    listboxIt can also be perfectly transparent.
    Is there any other way to make the control transparent.
    vb6The built-in controls are handy.If you use the system's standard controls.Setting it to be transparent is also good, but most of the manipulation methods need to use the API, which increases the difficulty a lot.

    If you write a software, the controls inside are transparent, the display effect is very shocking.
    vb.netIn many places, the positive side also uses false methods.The real sense of completely transparent design concept, it is estimated that only Google browser has achieved.
    Last edited by xiaoyao; Mar 29th, 2021 at 06:05 AM.

  7. #7

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Exclamation Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    It would be much easier for developers if someone could invent a way to search the world for code snippets. On this issue, I Bing search inside the search for hundreds of pages, spent a day, has been unable to find the results I want, VB6 users too few may also be my search keywords are not correct.
    It would be nice if webkit/webbrowser controls could be transparent.
    Last edited by xiaoyao; Mar 29th, 2021 at 06:23 AM.

  8. #8

  9. #9

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    Set a larger background image test.jpg for the form, and move the text box to see the transparency effect

    If there are other controls with handles under the text box, the text box will flicker continuously
    If the text control is moved multiple times to other white areas of the form and then moved out, the border of the text control will be partially contaminated and there will be residual image. Minimize the window and restore it to normal again.
    I don't know why, how to solve it

    Move to the label control where the text often changes
    You can drag the text box to test at will
    Transparent Textbox-01.zip
    Name:  Bug1-Transparent Textbox.jpg
Views: 713
Size:  29.3 KB

  10. #10

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    Quote Originally Posted by The trick View Post
    Transparent listbox Only FormPicture

    Just treat the background image of the form as a transparent basemap, and take a screenshot of the entire form.
    If there are other controls under the Listbox, transparency is a problem.
    How to monitor the UI change (picture or text) of any control on the form, and subclass each control to handle the WM_PAINT event?
    Suppose there are 4 controls at the bottom of the form, picture1, picture2, button1, button2,
    If picture1 has multiple other controls in this container control.
    Create a base map object MemPic1 and upload the background picture of the form
    If any control graphic in picture1 changes, copy the content of the client coordinate area of picture1 to the corresponding position of MemPic1?
    hBackBrush = CreatePatternBrush(MemPic1.Handle)
    If the transparent listbox1 control is placed in the container Picture1, create a second object MemPic2 as StdPicture, with the picture of the Picture1 control as the source of the background image?

    dos picturebox control also can hook WM_CTLCOLOREDIT?(SetBkMode wParam, TRANSPARENT)

    Code:
    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 = List1hwnd Or lParam = List2hwnd Then
                ' Устанавливаем прозрачный фон для текста
                SetBkMode wParam, TRANSPARENT
                ' Устанавливаем цвет текста
                'SetTextColor wParam, vbWhite
             SetTextColor wParam, vbRed
            'End If
            ' Возвращаем кисть
            'Ret = hBackBrush
            Ret = GetStockObject(NULL_BRUSH)
        Case Else:  DefCall = True  ' Остальное оставляем без изменений
        End Select
        
    End Sub
    How to return GetStockObject(NULL_BRUSH) in the event, it will be transparent when the software is opened for the first time, but when you click the listbox, the picture in the row is gone. When the window moves, I can’t see the picture behind the window.
    Name:  Transparent listbox GetStockObject(NULL_BRUSH).jpg
Views: 691
Size:  38.1 KB
    Attached Images Attached Images  
    Last edited by xiaoyao; Mar 29th, 2021 at 11:55 PM.

  11. #11

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)

    The text box transparent components do a module, direct call, very convenient. Support for adding multiple text boxes, and I wonder what other standard controls can be made transparent in this way.

    Code:
    Set TransparentControl1 = New TransparentTextBox
    TransparentControl1.AddHook Text1, Me.hwnd
    or

    Code:
        TransparentControl1.AddObj Text1
        TransparentControl1.AddObj Text2
        TransparentControl1.AddObj Text3
        
        TransparentControl1.StartHookControlList Form1.hwnd
    Code:
    TransparentTextBox.cls
    'need clsTrickSubclass
    
    Option Explicit
    
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    
    
    
    
    Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
    End Type
    
    Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long,  ByVal nIndex As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long,  ByVal fuRedraw As Long) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect 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 ExcludeClipRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long,  ByVal X2 As Long, ByVal Y2 As Long) As Long
    
    Private Const GWL_EXSTYLE       As Long = (-20)
    Private Const WS_EX_TRANSPARENT As Long = &H20&
    Private Const NULL_BRUSH        As Long = 5
    Private Const TRANSPARENT       As Long = 1
    Private Const WM_NCHITTEST      As Long = &H84
    Private Const WM_CTLCOLOREDIT   As Long = &H133
    
    Private Const RDW_INVALIDATE    As Long = &H1
    Private Const RDW_UPDATENOW     As Long = &H100&
    Private Const RDW_ALLCHILDREN   As Long = &H80
    
    Dim WithEvents mSubclass  As clsTrickSubclass
    Dim mIsCancel   As Boolean
    Public StopUpdate As Boolean
    Dim ControlHwnd As Long
    Dim Text1 As Control
    Dim ObjList As Collection
    Sub AddObj(obj As Control)
    ObjList.Add obj, "" & ObjList.Count
    End Sub
    Sub StartHookControlList(FormHwnd As Long)
    'Enable transparency for multiple controls
    
    For Each Text1 In ObjList
    ControlHwnd = Text1.hwnd
    SetWindowLong ControlHwnd, GWL_EXSTYLE, GetWindowLong(ControlHwnd, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
    Next
    Set ObjList = Nothing
    Set mSubclass = New clsTrickSubclass
    's american-american-American-American-American-American-American-American-American-American-American-American-American-
    mSubclass.Hook FormHwnd
    End Sub
    
    'Sub ReDraw()
    "" Eliminate border contamination
    '        Text1.BorderStyle = 0
    '        Text1.BorderStyle = 1
    "" Or the one below
    '        'ShowScrollBar Text1.hwnd, SB_HORZ, True
    '        'ShowScrollBar Text1.hwnd, SB_HORZ, False
    '
    '
    Redraw the background image
    '        Text1.Refresh
    'End Sub
    
    Sub AddHook(Text1A As Object, FormHwnd As Long)
    Set Text1 = Text1A
    ControlHwnd = Text1.hwnd
    SetWindowLong ControlHwnd, GWL_EXSTYLE, GetWindowLong(ControlHwnd, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
    Set mSubclass = New clsTrickSubclass
    's american-american-American-American-American-American-American-American-American-American-American-American-American-
    mSubclass.Hook FormHwnd
    End Sub
    
    Private Sub Class_Initialize()
    Set ObjList = New Collection
    End Sub
    
    Private Sub Class_Terminate()
    mSubclass.UnHook
    End Sub
    
    Private Sub mSubclass_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_CTLCOLOREDIT
    
    'hwnd is me.hwnd -- lParam is Text1.hwnd
    Static RC       As RECT
    Static isRedraw As Boolean 'Parent redraw flag
    
    'If the parent redraw flag is not set, redraw the background below
    If Not isRedraw And Not StopUpdate Then
    'Projects the coordinates of the work area onto the parent object
    GetClientRect lParam, RC 'original
    
    'GetWindowRect lParam, RC
    MapWindowPoints lParam, hwnd, RC, 2
    'Draws the parent background below the text box
    isRedraw = True
    RedrawWindow hwnd, RC, 0, RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_ALLCHILDREN
    isRedraw = False
    'Exclude the entire area because text was rendered on the previous call
    ExcludeClipRect wParam, 0, 0, RC.iRight, RC.iBottom
    Else
    Debug.Print "ignore"
    End If
    
    'Set the transparent brush and text background type
    SetBkMode wParam, TRANSPARENT
    Ret = GetStockObject(NULL_BRUSH)
    
    'Case WM_NCHITTEST: Ret = HTCAPTION 'Drag anywhere
    Case Else: DefCall = True
    End Select
    
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width