MakeTransparentTextbox Text1
HTML Code:
Attribute VB_Name = "ModTransparentTextbox"
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const GWL_WNDPROC = (-4)
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
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
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
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
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 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 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 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)
'Create the background brush (this brush is the bitmap brush)
CreateBGBrush aTxt
'If the main window is not subclassed, then start subclassing
'Here is a brief explanation of the use of GetProp and SetProc
'GetProc is to get the property of a window, and SetProc is to set the property of a window (the property value is 0 until the property value is set).
If GetProp(GetParent(aTxt.hwnd), "OrigProcAddr") = 0 Then
SetProp GetParent(aTxt.hwnd), "OrigProcAddr", SetWindowLong(GetParent(aTxt.hwnd), GWL_WNDPROC, AddressOf NewWindowProc)
End If
'If the textbox is not subclassed, then start subclassing
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
Dim imgLeft As Long
Dim imgTop As Long
Dim picDC As Long
Dim picBmp As Long
Dim aTempBmp As Long
Dim aTempDC As Long
Dim txtWid As Long
Dim txtHgt As Long
Dim SolidBrush As Long
Dim aRect As RECT
If aTxtBox.Parent.Picture Is Nothing Then Exit Sub
'Gets the values of the various properties of the text box, in pixels
txtWid = aTxtBox.Width / Screen.TwipsPerPixelX
txtHgt = aTxtBox.Height / Screen.TwipsPerPixelY
imgLeft = aTxtBox.Left / Screen.TwipsPerPixelX
imgTop = aTxtBox.Top / Screen.TwipsPerPixelY
screenDC = GetDC(0) 'To get the screenDC (DC is the device scene)
picDC = CreateCompatibleDC(screenDC) 'Create a memory DC picDC consistent with screenDC
PicBmp = SelectObject (picDC, aTxtBox. Parent. Picture. Handle) 'will be the main window of the background on the memory DC
aTempDC = CreateCompatibleDC(screenDC) 'Creates temporary memory DC aTempDC
aTempBmp = CreateCompatibleBitmap(screenDC, txtWid, txtHgt) 'to create a bitmap compatible with the screenDC
'Create a bitmap placeholder in preparation for the next BitBlt bitmap.
DeleteObject SelectObject(aTempDC, aTempBmp) 'selects the bitmap placeholder into aTempDC and deletes the aTempDC original
', the original content was a pure black background,
Copy bitmap from picDC to aTempDC
BitBlt aTempDC, 0, 0, txtWid, txtHgt, picDC, imgLeft, imgTop, vbSrcCopy
'If the bitmap brush is already set in the text box, reset the bitmap brush
If GetProp(aTxtBox.hwnd, "CustomBGBrush") <> 0 Then
DeleteObject GetProp(aTxtBox.hwnd, "CustomBGBrush")
End If
SetProp aTxtBox.hwnd, "CustomBGBrush", CreatePatternBrush(aTempBmp)
'扫尾工作
DeleteDC aTempDC
DeleteObject aTempBmp
SelectObject picDC, picBmp
DeleteDC picDC
DeleteObject picBmp
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
Dim origProc As Long
Dim isSubclassed As Long
origProc = GetProp(hwnd, "OrigProcAddr")
If origProc <> 0 Then
If (uMsg = WM_CTLCOLOREDIT) Then 'the text box control will send this message to the parent window when it is drawn. wParam is the DC of the text box control.
'lParam is the handle to the text box control
isSubclassed = (GetProp(lParam, "OrigProcAddr") <> 0)
If isSubclassed Then
CallWindowProc origProc, hwnd, uMsg, wParam, lParam
SetBkMode wParam, 1 'Sets the background mode of the text box control to transparent
NewWindowProc = GetProp(lParam, "CustomBGBrush") 'The key step is to change the background of the text box control
Else
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
ElseIf uMsg = WM_COMMAND Then 'Sends a WM_COMMAND message to the parent form when the text box control is fired
'Both having focus and typing characters in the text box trigger the message
isSubclassed = (GetProp(lParam, "OrigProcAddr") <> 0)
If isSubclassed Then
LockWindowUpdate GetParent(lParam) 'Locks the main window to prevent it from updating
InvalidateRect lParam, 0&, 1& 'masks the entire area of the text box window
UpdateWindow lParam 'forces an immediate update to the textbox window
End If
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
If isSubclassed Then LockWindowUpdate 0& 'To unlock a previously locked window
ElseIf uMsg = WM_DESTROY Then
SetWindowLong hwnd, GWL_WNDPROC, origProc
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
RemoveProp hwnd, "OrigProcAddr"
Else
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
Else
'如果有意外发生的话
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
Dim aRect As RECT
Dim origProc As Long
Dim aBrush As Long
origProc = GetProp(hwnd, "OrigProcAddr")
If origProc <> 0 Then
If uMsg = WM_ERASEBKGND Then 'This message is fired when the textbox window needs to be erased. wParam is the DC of the textbox
aBrush = GetProp(hwnd, "CustomBGBrush")
If aBrush <> 0 Then
GetClientRect hwnd, aRect
FillRect wParam, aRect, aBrush
NewTxtBoxProc = 1 'Tell the system that we have redrawn ourselves, or the system will redraw itself causing a flicker
Else
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
ElseIf uMsg = WM_HSCROLL Or uMsg = WM_VSCROLL Then
LockWindowUpdate GetParent(hwnd)
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
InvalidateRect hwnd, 0&, 1&
UpdateWindow hwnd
LockWindowUpdate 0&
ElseIf uMsg = WM_DESTROY Then
aBrush = GetProp(hwnd, "CustomBGBrush")
DeleteObject aBrush
RemoveProp hwnd, "OrigProcAddr"
RemoveProp hwnd, "CustomBGBrush"
SetWindowLong hwnd, GWL_WNDPROC, origProc
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
Else
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
Else
NewTxtBoxProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End If
End Function