Тень от формы - VB

Private isInit      As Boolean
Private wndProcAddr As Long
 
' // Apply shadow to form
Public Function SetShadowToForm( _
                ByVal hwnd As Long) As Boolean
    Dim hShadow As Long
    ' // Check previous set
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow Then Exit Function
    ' // Check initialize
    If Not isInit Then
        If Not Initialize Then Exit Function
    End If
    
    ' // Create shadow window (trnsparent-click, alphablend)
    hShadow = CreateWindowEx(WS_EX_LAYERED Or WS_EX_TRANSPARENT Or WS_EX_TOOLWINDOW, StrPtr(SHADOW_CLASS), StrPtr("#1"), WS_POPUP, 0, 0, 0, 0, 0, 0, App.hInstance, ByVal 0&)
    If hShadow = 0 Then Exit Function
    ' // Apply shadow window to passed window
    SetProp hwnd, PROP_NAME, hShadow
    ' // Make shadow effect
    MakeShadowForm hwnd, hShadow, 40, vbBlue, 25, 50
    ' // Subclass
    SetWindowSubclass hwnd, wndProcAddr, 0, hShadow
    ' // Show shadow
    ShowWindow hShadow, SW_SHOW
    
    SetShadowToForm = True
    
End Function
 
' // Remove shadow
Public Function RemoveShadow( _
                ByVal hwnd As Long) As Boolean
    Dim hShadow As Long
    ' // Check previous set
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Function
    ' // Destroy window
    DestroyWindow hShadow
    RemoveProp hwnd, PROP_NAME
    ' // Unsubclass
    RemoveWindowSubclass hwnd, wndProcAddr, 0
    
    RemoveShadow = True
    
End Function
 
' // Radius
Public Property Let Radius( _
                    ByVal hwnd As Long, _
                    ByVal newValue As Long)
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    ' // Check param
    If newValue <= 0 Or newValue > 100 Then Exit Property
    ' // Make shadow effect
    MakeShadowForm hwnd, hShadow, newValue, GetWindowLong(hShadow, 4), GetWindowLong(hShadow, 8), GetWindowLong(hShadow, 12)
End Property
Public Property Get Radius( _
                    ByVal hwnd As Long) As Long
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    Radius = GetWindowLong(hShadow, 0)
End Property
 
' // Color
Public Property Let Color( _
                    ByVal hwnd As Long, _
                    ByVal newValue As Long)
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    ' // Make shadow effect
    MakeShadowForm hwnd, hShadow, GetWindowLong(hShadow, 0), newValue, GetWindowLong(hShadow, 8), GetWindowLong(hShadow, 12)
End Property
Public Property Get Color( _
                    ByVal hwnd As Long) As Long
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    Color = GetWindowLong(hShadow, 4)
End Property
 
' // Contrast
Public Property Let Contrast( _
                    ByVal hwnd As Long, _
                    ByVal newValue As Long)
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    ' // Check param
    If newValue < 0 Or newValue > 100 Then Exit Property
    ' // Make shadow effect
    MakeShadowForm hwnd, hShadow, GetWindowLong(hShadow, 0), GetWindowLong(hShadow, 4), newValue, GetWindowLong(hShadow, 12)
End Property
Public Property Get Contrast( _
                    ByVal hwnd As Long) As Long
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    Contrast = GetWindowLong(hShadow, 8)
End Property
 
' // Opaque
Public Property Let Opaque( _
                    ByVal hwnd As Long, _
                    ByVal newValue As Long)
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    ' // Check param
    If newValue < 0 Or newValue > 100 Then Exit Property
    ' // Make shadow effect
    MakeShadowForm hwnd, hShadow, GetWindowLong(hShadow, 0), GetWindowLong(hShadow, 4), GetWindowLong(hShadow, 8), newValue
End Property
Public Property Get Opaque( _
                    ByVal hwnd As Long) As Long
    Dim hShadow As Long
    ' // Check is "shadowed"
    hShadow = GetProp(hwnd, PROP_NAME)
    If hShadow = 0 Then Exit Property
    Opaque = GetWindowLong(hShadow, 12)
End Property
 
' // Make new shadow image and update
Private Function MakeShadowForm( _
                 ByVal hwnd As Long, _
                 ByVal hShadow As Long, _
                 ByVal BlurRadius As Long, _
                 ByVal Color As Long, _
                 ByVal Contrast As Long, _
                 ByVal Opaque As Long) As Boolean
    Dim blurImage   As Long
    Dim bmpData()   As Byte
    Dim posX        As Long
    Dim posY        As Long
    Dim alpha       As Single
    Dim colorR      As Long
    Dim colorG      As Long
    Dim colorB      As Long
    Dim index       As Long
    Dim sngContrast As Single
    Dim sngOpaque   As Single
    
    ' // Allocate memory for blur bitmap
    ReDim bmpData(BlurRadius * 4 - 1, BlurRadius - 1)
    ' // Separate components
    colorB = Color And &HFF&
    colorG = (Color \ &H100) And &HFF&
    colorR = (Color \ &H10000) And &HFF&
    ' //
    sngContrast = Contrast / 100
    sngOpaque = Opaque / 100
    ' // Calc blur picture
    For posY = 0 To BlurRadius - 1: For posX = 0 To BlurRadius - 1
        
        alpha = Sqr(posX / BlurRadius * posX / BlurRadius + posY / BlurRadius * posY / BlurRadius)
        
        If alpha > 1 Then alpha = 1 Else If alpha < 0 Then alpha = 0
        
        alpha = GetBezier(alpha, sngContrast) * sngOpaque
        
        bmpData(index, posY) = colorR * alpha:  index = index + 1
        bmpData(index, posY) = colorG * alpha:  index = index + 1
        bmpData(index, posY) = colorB * alpha:  index = index + 1
        bmpData(index, posY) = 255 * alpha:     index = index + 1
        
    Next: index = 0: Next
    
    Dim rc      As RECT
    Dim width   As Long
    Dim height  As Long
    Dim bmpInfo As BITMAPINFO
    Dim hDC     As Long
    Dim tmpDC   As Long
    Dim dib     As Long
    Dim oBmp    As Long
    ' // Get form size
    GetWindowRect hwnd, rc
    ' // Calc picture size
    width = rc.iRight - rc.iLeft + BlurRadius * 2
    height = rc.iBottom - rc.iTop + BlurRadius * 2
    ' // Set bitmap info
    With bmpInfo.bmiHeader
        .biSize = Len(bmpInfo.bmiHeader)
        .biBitCount = 32
        .biHeight = height
        .biPlanes = 1
        .biWidth = width
    End With
    ' // Create DC
    tmpDC = GetDC(hwnd)
    hDC = CreateCompatibleDC(tmpDC)
    ReleaseDC hwnd, tmpDC
    ' // Create DIB
    dib = CreateDIBSection(hDC, bmpInfo, DIB_RGB_COLORS, 0, 0, 0)
    oBmp = SelectObject(hDC, dib)
    ' // Set bitmap info
    With bmpInfo.bmiHeader
        .biSize = Len(bmpInfo.bmiHeader)
        .biBitCount = 32
        .biHeight = BlurRadius
        .biPlanes = 1
        .biWidth = BlurRadius
    End With
    ' // Draw corners
    StretchDIBits hDC, 0, 0, BlurRadius, BlurRadius, BlurRadius, 0, -BlurRadius, BlurRadius, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    StretchDIBits hDC, 0, height - BlurRadius, BlurRadius, BlurRadius, BlurRadius, BlurRadius, -BlurRadius, -BlurRadius, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    StretchDIBits hDC, width - BlurRadius, 0, BlurRadius, BlurRadius, 0, 0, BlurRadius, BlurRadius, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    StretchDIBits hDC, width - BlurRadius, height - BlurRadius, BlurRadius, BlurRadius, 0, BlurRadius, BlurRadius, -BlurRadius, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    ' // Draw sides
    StretchDIBits hDC, BlurRadius - 1, 0, width - BlurRadius * 2 + 1, BlurRadius, 0, 0, 1, BlurRadius, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    StretchDIBits hDC, BlurRadius - 1, height - BlurRadius, width - BlurRadius * 2 + 1, BlurRadius, 0, BlurRadius, 1, -BlurRadius, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    StretchDIBits hDC, 0, BlurRadius, BlurRadius, height - BlurRadius * 2 + 1, BlurRadius, 0, -BlurRadius, 1, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    StretchDIBits hDC, width - BlurRadius, BlurRadius, BlurRadius, height - BlurRadius * 2 + 1, 0, 0, BlurRadius, 1, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    ' // Center
    StretchDIBits hDC, BlurRadius - 1, BlurRadius - 1, width - BlurRadius * 2 + 1, height - BlurRadius * 2 + 1, 0, 0, 1, 1, bmpData(0, 0), bmpInfo, DIB_RGB_COLORS, vbSrcCopy
    ' // Move window
    SetWindowPos hShadow, hwnd, rc.iLeft - BlurRadius, rc.iTop - BlurRadius, width, height, SWP_NOACTIVATE
    ' //
    Dim pt As POINTAPI
    Dim sz As SIZE
    
    sz.cx = width
    sz.cy = height
    
    UpdateLayeredWindow hShadow, hDC, ByVal 0, sz, hDC, pt, 0, AB_32Bpp255, ULW_ALPHA
    
    ' // Store parameters
    SetWindowLong hShadow, 0, ByVal BlurRadius
    SetWindowLong hShadow, 4, ByVal Color
    SetWindowLong hShadow, 8, ByVal Contrast
    SetWindowLong hShadow, 12, ByVal Opaque
    
    ' // Free resources
    SelectObject hDC, oBmp
    DeleteDC hDC
    DeleteObject dib
    
    MakeShadowForm = True
    
End Function
 
' // Get value of quadratic-Bezier curve into X point with controls point (0,1);(z,z);(1,0)
Private Function GetBezier( _
                 ByVal x As Single, _
                 ByVal z As Single) As Single
    Dim t As Single, b As Single
    
    b = -2 * z
    If b = -1 Then GetBezier = 1 - x: Exit Function
    
    t = (b + Sqr(b * b + 4 * (1 + b) * x)) / (2 * (b + 1))
    GetBezier = (1 - t) * (1 - t) + 2 * z * t * (1 - t)
    
End Function
 
Private Function Initialize() As Boolean
    Dim cls As WNDCLASSEX
    ' // Register class for shadow window
    cls.hInstance = App.hInstance
    cls.lpfnwndproc = GetProcAddress(GetModuleHandle("user32"), "DefWindowProcW")
    cls.lpszClassName = StrPtr(SHADOW_CLASS)
    cls.cbSize = Len(cls)
    cls.cbWndExtra2 = 16
    
    If RegisterClassEx(cls) = 0 Then
        If Err.LastDllError <> ERROR_CLASS_ALREADY_EXISTS Then Exit Function
    End If
    
    wndProcAddr = GetAddress(AddressOf WndProc)
    
    isInit = True
    Initialize = True
    
End Function
 
Private Function WndProc( _
                 ByVal hwnd As Long, _
                 ByVal uMsg As Long, _
                 ByVal wParam As Long, _
                 ByVal lParam As Long, _
                 ByVal uIdSubclass As Long, _
                 ByVal hShadow As Long) As Long
    Dim isMove  As Boolean
    
    Select Case uMsg
    Case WM_WINDOWPOSCHANGED
        Dim wndPos      As WINDOWPOS
        
        If IsWindowVisible(hShadow) Then
            CopyMemory wndPos, ByVal lParam, Len(wndPos)
            
            ' // Resize
            If Not CBool(wndPos.flags And SWP_NOSIZE) Then
                MakeShadowForm hwnd, hShadow, GetWindowLong(hShadow, 0), GetWindowLong(hShadow, 4), GetWindowLong(hShadow, 8), GetWindowLong(hShadow, 12)
            Else 'If Not CBool(wndPos.flags And SWP_NOMOVE) Then
                isMove = True
            End If
        End If
        
    Case WM_ACTIVATE, WM_ACTIVATEAPP, WM_EXITSIZEMOVE
        
         isMove = True
    
    Case WM_SYSCOMMAND
        
        Select Case wParam
        Case SC_MAXIMIZE, SC_MINIMIZE
            ShowWindow hShadow, SW_HIDE
        Case SC_RESTORE
            ShowWindow hShadow, SW_SHOW
            isMove = True
        Case Else
            isMove = True
        End Select
        
    Case WM_DESTROY
    
         RemoveShadow hwnd
         Exit Function
         
    End Select
    
    WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
    
    If isMove Then
        Dim rc  As RECT
        Dim BlurRadius  As Long
        
        GetWindowRect hwnd, rc
        
        BlurRadius = GetWindowLong(hShadow, 0)
        
        ' // Move shadow
        SetWindowPos hShadow, hwnd, rc.iLeft - BlurRadius, rc.iTop - BlurRadius, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_NOOWNERZORDER
 
    End If
    
End Function
 
Private Function GetAddress( _
                 ByVal Address As Long) As Long
    GetAddress = Address
End Function