Прозрачный textbox, сквозь который будет видно фон формы - VB - Ответ 6515495

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