Форма становится прозрачной, а кнопка - нет - VB - Ответ 6441097

Option Explicit
 
Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
End Type
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(31) As Byte
End Type
 
Private Declare Function InitCommonControlsEx Lib "comctl32" (icc As Any) 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32" (ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, ByVal WidthDest As Long, ByVal HeightDest As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long, ByVal Blendfunc As Long) As Long
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) 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 GetParent Lib "user32" (ByVal hwnd As Long) 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 GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetUpdateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase 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 SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetViewportOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As Any) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
 
Private Const GW_HWNDNEXT       As Long = 2
Private Const WM_PAINT          As Long = &HF
Private Const WM_ERASEBKGND     As Long = &H14
Private Const RDW_UPDATENOW     As Long = &H100
Private Const RDW_INVALIDATE    As Long = &H1
 
Dim WithEvents sclButton    As clsTrickSubclass
 
Private Sub Form_Initialize()
    InitCommonControlsEx 3435973.8623@
End Sub
 
Private Sub Form_Load()
    Dim p As Long
    
    Set sclButton = New clsTrickSubclass
    sclButton.HookClass cmdTest(0).hwnd
    sclButton.ResumeSubclass
 
    For p = 1 To 6
        Load cmdTest(p)
        cmdTest(p).Move 5, p * 50 + 5, ScaleWidth - 10, 45
        cmdTest(p).Visible = True
        cmdTest(p).ZOrder
        cmdTest(p).Caption = Choose(p, "Transparent", _
                                       "buttons", _
                                       "by The trick", _
                                       "use TrickSubclass", _
                                       "fake transparent", _
                                       "double buffering")
    Next
    
End Sub
 
Private Sub hsbAlpha_Change()
    Dim i As Long
    For i = 0 To cmdTest.UBound: cmdTest(i).Refresh: Next
End Sub
Private Sub hsbAlpha_Scroll()
    hsbAlpha_Change
End Sub
 
Private Sub sclButton_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_ERASEBKGND: OnErase hwnd, wParam, lParam
    Case WM_PAINT: OnPaint hwnd
    Case Else: DefCall = True
    End Select
End Sub
 
Private Sub OnErase(ByVal hwnd As Long, ByVal hdc As Long, ByVal ID As Long)
    Dim rc As RECT, map As RECT, nWnd As Long
    
    If ID <> hwnd Then Exit Sub
    
    nWnd = GetParent(hwnd)
    GetUpdateRect hwnd, rc, 0
    map = rc: MapWindowPoints hwnd, nWnd, map, 2
    SetViewportOrgEx hdc, -map.iLeft, -map.iTop, ByVal 0&
    SendMessage nWnd, WM_PAINT, hdc, ByVal 0&
    nWnd = GetWindow(hwnd, GW_HWNDNEXT)
    
    Do While nWnd
        map = rc: MapWindowPoints hwnd, nWnd, map, 2
        SetViewportOrgEx hdc, -map.iLeft, -map.iTop, ByVal 0&
        SendMessage nWnd, WM_PAINT, hdc, ByVal 0&
        SelectClipRgn hdc, 0
        nWnd = GetWindow(nWnd, GW_HWNDNEXT)
    Loop
 
    SetViewportOrgEx hdc, 0, 0, ByVal 0&
    
End Sub
Private Sub OnPaint(ByVal hwnd As Long)
    Dim sDc As Long, sBmp As Long, soBmp As Long, _
        dDc As Long, dBmp As Long, doBmp As Long, _
        rc As RECT, ps As PAINTSTRUCT
    
    GetUpdateRect hwnd, rc, 0
    sDc = CreateCompatibleDC(Me.hdc):   dDc = CreateCompatibleDC(Me.hdc)
    sBmp = CreateCompatibleBitmap(Me.hdc, rc.iRight, rc.iBottom)
    dBmp = CreateCompatibleBitmap(Me.hdc, rc.iRight, rc.iBottom)
    soBmp = SelectObject(sDc, sBmp):    doBmp = SelectObject(dDc, dBmp)
    sclButton.CallDef hwnd, WM_PAINT, sDc, 0, False
    BeginPaint hwnd, ps
    SendMessage hwnd, WM_ERASEBKGND, dDc, ByVal hwnd
    AlphaBlend dDc, rc.iLeft, rc.iTop, rc.iRight - rc.iLeft, rc.iBottom - rc.iTop, _
               sDc, rc.iLeft, rc.iTop, rc.iRight - rc.iLeft, rc.iBottom - rc.iTop, CLng(hsbAlpha.Value) * &H10000
    BitBlt ps.hdc, rc.iLeft, rc.iTop, rc.iRight - rc.iLeft, rc.iBottom - rc.iTop, dDc, rc.iLeft, rc.iTop, vbSrcCopy
    EndPaint hwnd, ps
    SelectObject sDc, soBmp:    SelectObject dDc, doBmp
    DeleteObject sBmp:          DeleteObject dBmp
    DeleteDC sDc:               DeleteDC dDc
    
End Sub