' **************************************************************************************
'  Subclassed Multilined text boxes (for transparency effect)
' **************************************************************************************
'
'          Author: G. D. Sever (aka The Hand)
'            ate: Sept, 2002
'
'     Description: This module allows the user to create a "transparent" effect for
'                  VB's standard textboxes. It creates brush objects for the textbox
'                  and then uses them when the textbox draws itself to paint the
'                  background area.
'
'                  In its current incarnation, we simply use the picture which is on
'                  the textboxes' form, however this can me modified in the CreateBGBrush
'                  subroutine to use whatever image you wish. In addition, you could do
'                  additional processing in WM_ERASEBKGND section of NewTxtBoxProc, such
'                  as adding a logo, text, horizontal lines, etc.
'
'    Terms of use: You are welcome to use this code in your projects and modify it
'                  to suit your needs. However if you wish to publish code from
'                  this module, either in part or as a whole, as part of your
'                  modified project, you must give us credit for those pieces
'                  which are ours and obtain our permission.
'
' **************************************************************************************
'   Visit EliteVB.com for more high-powered API and subclassing solutions!
' **************************************************************************************

Option Explicit

' APIs to install our subclassing routines
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 "efWindowProcA" (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)
    eleteObject 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
    eleteObject 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.
        eleteObject 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
    eleteDC aTempDC
    eleteObject 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
    eleteDC picDC
    eleteObject 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.
            eleteObject 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

Private Sub Form_Load()

    ' Image comes from http://www.desktop-fx.com/wallpaper/pat_fractal_002.htm#
    Set Me.Picture = LoadPicture(App.Path & "\" & "pat_fra_dfx_016b.jpg"
    makeTransparentTextbox txtSingle
    makeTransparentTextbox txtMulti
    
  '  Set Me.Picture = Nothing
End Sub

Private Sub Form_Resize()
    On Local Error Resume Next
    txtSingle.Move txtSingle.Left, txtSingle.Top, Me.ScaleWidth - txtSingle.Left * 2
    makeTransparentTextbox txtSingle
    txtMulti.Move txtMulti.Left, txtMulti.Top, Me.ScaleWidth - txtMulti.Left * 2, Me.ScaleHeight - txtMulti.Top - txtSingle.Top
    makeTransparentTextbox txtMulti
End Sub