'inside a module
'>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<
' Example of Transparent Textbox
'
' Written by Aaron Young, June 2001
'
'>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) 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 Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
Private Const WM_CTLCOLOREDIT = &H133
Private Const WM_MOVE = &H3
Private Const WM_COMMAND = &H111
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const EM_GETRECT = &HB2
Private Const SRCCOPY = &HCC0020
Private lFormHwnd As Long
Private oEdit As TextBox
Private lBackGround As Long
Private lBitmap As Long
Private lOldObj As Long
Private lWindowFunc As Long
Private lBrush As Long
Public Sub MakeTransparent(ByVal hwnd As Long, ByRef oTextEdit As TextBox)
' Subclass the WindowProc of the Form Window and
' Get a Reference to the Textbox we want to make appear Transparent
lFormHwnd = hwnd
Set oEdit = oTextEdit
lWindowFunc = SetWindowLong(lFormHwnd, GWL_WNDPROC, AddressOf WindowCallBack)
End Sub
Public Sub ReleaseTransparency()
' Release the Subclass on the Forms WindowProc
' And Release the reference to the Textbox
Call SetWindowLong(lFormHwnd, GWL_WNDPROC, lWindowFunc)
Set oEdit = Nothing
' Clean up the Brush, Bitmap and HDC created for the Transparency effect
Call SelectObject(lBackGround, lOldObj)
Call DeleteObject(lBitmap)
Call DeleteObject(lBrush)
Call DeleteDC(lBackGround)
End Sub
Public Sub GetBackGround(ByVal hwnd As Long)
' Make the Textbox appear transparent, by painting it with the image
' from the Desktop currently under the Textbox control.
Dim tWIN As RECT
Dim lObj As Long
Dim lDeskDC As Long
Dim bNew As Boolean
' Hide the Form containing the Textbox to expose the DeskTop underneath
' To get rid of the "Focus" effect, consider moving the Form off screen instead
' So that it retains focus.
Call ShowWindow(lFormHwnd, SW_HIDE)
DoEvents
' Track whether we're doing this for the first time.
bNew = (lBitmap = 0)
' If it's not the First time, delete the old Brush, Bitmap and HDC
' To preserve GDI resources
If Not bNew Then
Call DeleteObject(lBrush)
Call SelectObject(lBackGround, lOldObj)
Call DeleteObject(lBitmap)
Call DeleteDC(lBackGround)
End If
' Get the area occupied by the Textbox
Call GetWindowRect(oEdit.hwnd, tWIN)
With tWIN
' Grap a DC for the Desktop
lDeskDC = GetDC(0)
' Create a compatible Bitmap with the Desktop DC the size of the Textbox Area
lBitmap = CreateCompatibleBitmap(lDeskDC, .Right - .Left, .Bottom - .Top)
' Create a compatible DC to store the current transparency image in.
lBackGround = CreateCompatibleDC(lDeskDC)
' Select the Bitmap into the DC
lOldObj = SelectObject(lBackGround, lBitmap)
' Now copy the currenty image from the Desktop to the Temp. DC
BitBlt lBackGround, 0, 0, .Right - .Left, .Bottom - .Top, lDeskDC, .Left, .Top, SRCCOPY
End With
' Create a Brush using the Bitmap to be used by the Textbox when repainting.
lBrush = CreatePatternBrush(lBitmap)
' Release the Desktop DC and Show the Form again.
Call ReleaseDC(0, lDeskDC)
Call ShowWindow(lFormHwnd, SW_SHOW)
End Sub
Private Function WindowCallBack(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tRECT As RECT
' Trap any unforeseen errors
On Error Resume Next
Select Case Msg
Case WM_CTLCOLOREDIT
' The WM_CTLCOLOREDIT is sent to the Form when the Editbox is about to be repainted
' By Returning a Brush handle we can control what's used to paint the background
' To make the Box appear transparent, pass a Bitmap of the area under the Form
' Set the Background Mode to Transparent so that the "TextOut" operations
' Don't fill the spaces around the Text with a solid background color.
Call SetBkMode(wParam, TRANSPARENT)
WindowCallBack = lBrush
Case WM_MOVE
' Triggered when the Form has been moved, at this point we want to get a fresh
' Snapshot of what's under the Form to maintain the illusion of Transparency.
Call GetBackGround(lFormHwnd)
WindowCallBack = CallWindowProc(lWindowFunc, hwnd, Msg, wParam, lParam)
Case WM_COMMAND
' Triggered when the Form recieves a command for the Textbox, if you have more than
' The Textbox on the Form, you'll want to single out your Textbox from the messages
' Call the default behaviour first in this case, so we have the opportunity
' To clean up unwanted side-effects of this implementation.
WindowCallBack = CallWindowProc(lWindowFunc, hwnd, Msg, wParam, lParam)
' Part of the Problem with this method is the Textbox only updates the line it's on
' This causes ugly graphical side effects when you backup over text or scroll down
' The Textbox outside the visible area.
' To get around this, I'm issuing a "Refresh" after each "WM_COMMAND" to update the
' whole textbox area, this can give an annoying flicker, but like I said, it aint
' Perfect, but it's a starting point.
' To make this nicer you could narrow down to the calls that cause the annoying
' Glitches and only refresh in those instances.
Call SendMessage(lParam, EM_GETRECT, 0, tRECT)
Call InvalidateRect(lParam, tRECT, 1)
Call UpdateWindow(lParam)
Case Else
WindowCallBack = CallWindowProc(lWindowFunc, hwnd, Msg, wParam, lParam)
End Select
End Function
' Some basic Word manipulation functions, these can be used to extract
' The windows message sent with the "WM_COMMAND" message, see API Help
' Form detais.
Public Function LoWord(ByVal lValue As Long) As Long
LoWord = lValue And &HFFFF&
End Function
Public Function HiWord(ByVal lValue As Long) As Long
HiWord = (lValue / &H10000) And &HFFFF&
End Function
Public Function MakeLong(ByVal lLo As Long, ByVal lHi As Long) As Long
MakeHiLoWord = (lHi * &H10000) + lLo
End Function
Reply With Quote
