Пользовательская отрисовка окна

Option Explicit
 
' Модуль пользовательской отрисовки неклиентской области окна
' + поддержка индикатора прогресса панели задач (Win7)
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Private Const LF_FACESIZE = 32
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type AnimIcon
    Sequence As Long
    NumOfFrame As Long
    CurFrame As Long
    State As Long
    Interval As Long
    Looped As Boolean
End Type
Private Type WndExtInfo
    lpOldWndProc As Long
    ProgressValue As Single
    ProgressState As Taskbarlib.TBPFLAG
    Icon As AnimIcon
    ButtonsState As Long
End Type
Private Type StatePicture
    Active As StdPicture
    Inactive As StdPicture
End Type
Private Type NCCALCSIZE_PARAMS
    rgrc(2) As RECT
    lpWindowPos As Long
End Type
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type tagTRACKMOUSEEVENT
    cbSize As Long
    dwFlags As Long
    hwndTrack As Long
    dwHoverTime As Long
End Type
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
 
Private Declare Function TrackMouseEvent Lib "user32" (ByRef lpEventTrack As tagTRACKMOUSEEVENT) 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 HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetMem8 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnclip As Long, ByVal fdwOptions As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 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 GetActiveWindow Lib "user32" () 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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () 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 StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop 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 Declare Function IntersectClipRect 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 Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthW" (ByVal hwnd As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub vbaObjAddRef Lib "msvbvm60.dll" Alias "__vbaObjAddref" (nClass As Any)
Private Declare Sub vbaObjSet Lib "msvbvm60.dll" Alias "__vbaObjSet" (Dst As Any, Src As Any)
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
 
Private Const TRANSPARENT = 1
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const HEAP_NO_SERIALIZE = &H1
Private Const GWL_WNDPROC = &HFFFFFFFC
Private Const GWL_USERDATA = (-21)
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_EX_CONTEXTHELP = &H400&
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const DCX_WINDOW = &H1&
Private Const DCX_INTERSECTRGN = &H80&
Private Const DCX_CLIPSIBLINGS = &H10&
Private Const SIZE_MINIMIZED = 1
Private Const SIZE_MAXIMIZED = 2
Private Const RGN_OR = 2
Private Const RDW_FRAME = &H400
Private Const RDW_INVALIDATE = &H1
Private Const HTLEFT = 10
Private Const HTTOP = 12
Private Const HTRIGHT = 11
Private Const HTBOTTOM = 15
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTBOTTOMRIGHT = 17
Private Const HTBOTTOMLEFT = 16
Private Const HTCAPTION = 2
Private Const HTCLIENT = 1
Private Const HTCLOSE = 20
Private Const HTMAXBUTTON = 9
Private Const HTMINBUTTON = 8
Private Const HTSYSMENU = 3
Private Const HTHELP = 21
Private Const HTTRANSPARENT = (-1)
Private Const TME_LEAVE = &H2
Private Const TME_QUERY = &H40000000
Private Const TME_NONCLIENT = &H10
Private Const TME_CANCEL = &H80000000
Private Const WS_THICKFRAME = &H40000
Private Const VK_LBUTTON = &H1
Private Const SC_CLOSE = &HF060&
Private Const SC_CONTEXTHELP = &HF180&
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_MINIMIZE = &HF020&
Private Const SC_RESTORE = &HF120&
Private Const DT_END_ELLIPSIS = &H8000&
Private Const RDW_UPDATENOW = &H100
Private Const ICON_BIG = 1
Private Const DI_NORMAL = 3
Private Const AB_32Bpp255 = 33488896
 
Private Const WM_NCPAINT = &H85
Private Const WM_NCCALCSIZE = &H83
Private Const WM_NCACTIVATE = &H86
Private Const WM_NCUAHDRAWCAPTION = &HAE
Private Const WM_NCHITTEST = &H84
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCMOUSEMOVE = &HA0
Private Const WM_NCMOUSELEAVE = &H2A2
Private Const WM_SYSCOMMAND = &H112
Private Const WM_SIZE = &H5
Private Const WM_POPUPSYSTEMMENU = &H313
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONUP = &H202
Private Const WM_GETICON = &H7F&
Private Const WM_TIMER = &H113
 
Private Const SIZE_CAPTION = 38
Private Const SIZE_BORDER = 4
Private Const SIZE_ICON = 32
Private Const BUT_CLOSE = 0
Private Const BUT_MAX = 1
Private Const BUT_MIN = 2
Private Const BUT_HELP = 3
Private Const BUT_SPACING = 4
Private Const STA_OVER = 1
Private Const STA_DOWN = 2
 
Dim hHeap               As Long
Dim wCount              As Long
Dim bufDC               As Long
Dim buf2DC              As Long
Dim bufBmp              As Long
Dim bufoBmp             As Long
Dim picInit             As Boolean
Dim picWnd              As StatePicture
Dim picBut()            As StdPicture
Dim picPrg              As StatePicture
Dim sysnc               As NONCLIENTMETRICS
Dim capFont             As Long
Dim Task                As Taskbarlib.TaskbarList
 
' Установить стиль отрисовки окну
Public Function SetNCSkin(frm As Form) As Boolean
    Dim wi As WndExtInfo, pt As Long
    pt = GetWindowLong(frm.hwnd, GWL_USERDATA)
    If pt Then Exit Function
    If Not picInit Then LoadSkin
    If hHeap = 0 Then
        hHeap = HeapCreate(HEAP_NO_SERIALIZE, Len(wi), 0)
        If hHeap = 0 Then Exit Function
    End If
    pt = HeapAlloc(hHeap, HEAP_NO_SERIALIZE, Len(wi))
    If pt = 0 Then
        If wCount = 0 Then HeapDestroy hHeap: hHeap = 0
        Exit Function
    End If
    wCount = wCount + 1
    wi.ProgressState = TBPF_NOPROGRESS
    wi.ProgressValue = 0
    wi.lpOldWndProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf WndProc)
    SetWindowLong frm.hwnd, GWL_USERDATA, pt
    CopyMemory ByVal pt, wi, Len(wi)
    SetNCSkin = True
End Function
' Убрать стиль отрисовки у окна
Public Function RemoveNCSkin(frm As Form) As Boolean
    Dim wi As WndExtInfo, pt As Long, bmp As StdPicture
    If hHeap = 0 Or wCount = 0 Then Exit Function
    pt = GetWindowLong(frm.hwnd, GWL_USERDATA)
    If pt = 0 Then Exit Function
    CopyMemory wi, ByVal pt, Len(wi)
    SetWindowLong frm.hwnd, GWL_WNDPROC, wi.lpOldWndProc
    SetWindowLong frm.hwnd, GWL_USERDATA, 0
    HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal pt
    wCount = wCount - 1
    If wCount = 0 Then
        DeleteDC bufDC
        SelectObject buf2DC, bufoBmp
        DeleteDC buf2DC
        DeleteObject bufBmp
        DeleteObject capFont
        HeapDestroy hHeap: hHeap = 0
        Set Task = Nothing
    End If
    RemoveNCSkin = True
End Function
' Установить анимированную иконку окну с пользовательскм стилем отрисовки
Public Function SetIcon(frm As Form, Icon As StdPicture, ByVal NumFrames As Long) As Boolean
    Dim wi As WndExtInfo, rc As RECT
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    wi.Icon.CurFrame = 0
    wi.Icon.NumOfFrame = NumFrames
    wi.Icon.State = 0
    wi.Icon.Sequence = ObjPtr(Icon)
    SetExtInfo frm.hwnd, wi
    vbaObjAddRef ByVal wi.Icon.Sequence
    SetRect rc, -SIZE_BORDER, -SIZE_CAPTION, SIZE_ICON, 0
    RedrawWindow frm.hwnd, rc, 0, RDW_FRAME Or RDW_INVALIDATE
    SetIcon = True
End Function
' Проиграть анимацию в окне с пользовательским стилем отрисовки
Public Function PlayAnimation(frm As Form, Optional ByVal IntervalMS As Long = 100, Optional ByVal Looped As Boolean = False) As Boolean
    Dim wi As WndExtInfo
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    wi.Icon.CurFrame = 0
    wi.Icon.State = 1
    wi.Icon.Looped = Looped
    SetExtInfo frm.hwnd, wi
    SetTimer frm.hwnd, frm.hwnd, IntervalMS, 0
    PlayAnimation = True
End Function
' Остановить анимацию в окне с пользовательским стилем отрисовки
Public Function StopAnimation(frm As Form) As Boolean
    Dim wi As WndExtInfo, hdc As Long
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    If wi.Icon.State = 1 Then KillTimer frm.hwnd, frm.hwnd
    wi.Icon.State = 0
    wi.Icon.CurFrame = 0
    SetExtInfo frm.hwnd, wi
    hdc = GetDCEx(frm.hwnd, 0, DCX_WINDOW Or DCX_CLIPSIBLINGS)
    myDrawIcon frm.hwnd, buf2DC
    BitBlt hdc, SIZE_BORDER, 0, SIZE_ICON, SIZE_CAPTION, buf2DC, SIZE_BORDER, 0, vbSrcCopy
    ReleaseDC frm.hwnd, hdc
    StopAnimation = True
End Function
' Задать состояние индикатора прогресса в окне с пользовательским стилем отрисовки и на панели задач (Win7)
Public Function SetProgressState(frm As Form, ByVal State As Taskbarlib.TBPFLAG) As Boolean
    Dim wi As WndExtInfo
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    wi.ProgressState = State
    SetExtInfo frm.hwnd, wi
    InvalidateProgress frm.hwnd
    SetProgressState = True
    If Not Task Is Nothing Then Task.SetProgressState frm.hwnd, State
End Function
' Получить состояние индикатора прогресса в окне с пользовательским стилем отрисовки и на панели задач (Win7)
Public Function GetProgressState(frm As Form) As Taskbarlib.TBPFLAG
    Dim wi As WndExtInfo
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    GetProgressState = wi.ProgressState
End Function
' Задать значение индикатора прогресса в окне с пользовательским стилем отрисовки и на панели задач (Win7)
Public Function SetProgressValue(frm As Form, ByVal Value As Single) As Boolean
    Dim wi As WndExtInfo
    If Value < 0 Or Value > 1 Then Exit Function
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    wi.ProgressValue = Value
    SetExtInfo frm.hwnd, wi
    SetProgressValue = True
    If wi.ProgressState <> TBPF_NOPROGRESS Then InvalidateProgress frm.hwnd
    If Not Task Is Nothing Then Task.SetProgressValue frm.hwnd, CCur(Value * 10000), CCur(10000)
End Function
' Получить значение индикатора прогресса в окне с пользовательским стилем отрисовки и на панели задач (Win7)
Public Function GetProgressValue(frm As Form) As Single
    Dim wi As WndExtInfo
    If Not GetExtInfo(frm.hwnd, wi) Then Exit Function
    GetProgressValue = wi.ProgressValue
End Function
Private Function GetExtInfo(ByVal hwnd As Long, wi As WndExtInfo) As Boolean
    Dim pt As Long
    If hHeap = 0 Or wCount = 0 Then Exit Function
    pt = GetWindowLong(hwnd, GWL_USERDATA)
    If pt = 0 Then Exit Function
    CopyMemory wi, ByVal pt, Len(wi)
    GetExtInfo = True
End Function
Private Function SetExtInfo(ByVal hwnd As Long, wi As WndExtInfo) As Boolean
    Dim pt As Long
    If hHeap = 0 Or wCount = 0 Then Exit Function
    pt = GetWindowLong(hwnd, GWL_USERDATA)
    If pt = 0 Then Exit Function
    CopyMemory ByVal pt, wi, Len(wi)
    SetExtInfo = True
End Function
Private Function LoadSkin() As Boolean
    Dim dhwnd As Long, ddc As Long
    Set picWnd.Active = LoadResPicture("ACTIVEWINDOW", vbResBitmap)
    Set picWnd.Inactive = LoadResPicture("INACTIVEWINDOW", vbResBitmap)
    Set picPrg.Active = LoadResPicture("PROGRESSACTIVE", vbResBitmap)
    Set picPrg.Inactive = LoadResPicture("PROGRESSINACTIVE", vbResBitmap)
    ReDim picBut(3)
    Set picBut(BUT_CLOSE) = LoadResPicture("CLOSEBUTTON", vbResBitmap)
    Set picBut(BUT_MAX) = LoadResPicture("MAXIMIZEBUTTON", vbResBitmap)
    Set picBut(BUT_MIN) = LoadResPicture("MINIMIZEBUTTON", vbResBitmap)
    Set picBut(BUT_HELP) = LoadResPicture("HELPBUTTON", vbResBitmap)
    
    dhwnd = GetDesktopWindow()
    ddc = GetDC(dhwnd)
    bufDC = CreateCompatibleDC(ddc)
    buf2DC = CreateCompatibleDC(ddc)
    SetBkMode buf2DC, TRANSPARENT
    ReleaseDC dhwnd, ddc
    
    sysnc.cbSize = Len(sysnc)
    SystemParametersInfo SPI_GETNONCLIENTMETRICS, Len(sysnc), sysnc, 0
    
    capFont = CreateFontIndirect(sysnc.lfCaptionFont)
 
    bufBmp = CreateBitmap(2048, SIZE_CAPTION, 1, 32, ByVal 0)
    bufoBmp = SelectObject(buf2DC, bufBmp)
 
    On Error Resume Next
    Set Task = New Taskbarlib.TaskbarList
    picInit = True
End Function
Private Function WndProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case msg
    Case WM_NCUAHDRAWCAPTION
    Case WM_LBUTTONUP
        WndProc = OnLButtonUp(hwnd, wParam, lParam)
    Case WM_MOUSEMOVE
        WndProc = OnMouseMove(hwnd, wParam, lParam)
    Case WM_NCMOUSELEAVE
        WndProc = OnNCMouseLeave(hwnd)
    Case WM_NCMOUSEMOVE
        WndProc = OnNCMouseMove(hwnd, wParam, lParam)
    Case WM_NCLBUTTONDOWN
        WndProc = OnNCLButtonDown(hwnd, wParam, lParam)
    Case WM_NCHITTEST
        WndProc = OnNCHitTest(hwnd, lParam And &HFFFF&, (lParam \ &H10000) And &HFFFF&)
    Case WM_SIZE
        WndProc = OnSize(hwnd, wParam, lParam And &HFFFF&, (lParam \ &H10000) And &HFFFF&)
    Case WM_NCPAINT
        WndProc = OnNCPaint(hwnd, wParam)
    Case WM_NCCALCSIZE
        WndProc = OnNCCalcSize(hwnd, wParam, lParam)
    Case WM_NCACTIVATE
        WndProc = OnNCActivate(hwnd, wParam)
    Case WM_TIMER
        WndProc = OnTimer(hwnd, wParam, lParam)
    Case Else
        WndProc = CallOldWndProc(hwnd, msg, wParam, lParam)
    End Select
End Function
Private Function CallOldWndProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lpOldProc As Long, OldProc As Long
    lpOldProc = GetWindowLong(hwnd, GWL_USERDATA)
    GetMem4 ByVal lpOldProc, OldProc
    CallOldWndProc = CallWindowProc(OldProc, hwnd, msg, wParam, lParam)
End Function
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\Процедуры окна\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Private Function OnNCPaint(ByVal hwnd As Long, hRgn As Long) As Long
    Dim rc As RECT, hdc As Long, pic As StdPicture, Btn() As Long, i As Long, x As Long, y As Long, iw As Long, st As Long, _
        ct As Long, txt As String, bwa As LogEventTypeConstants, ofnt As Long, wi As WndExtInfo, capw As Long, rctxt As RECT
    
    GetWindowRect hwnd, rc
    If GetActiveWindow() = hwnd Then Set pic = picWnd.Active: st = 0 Else Set pic = picWnd.Inactive: st = 3
 
    If hRgn <> 1 Then
        hdc = GetDCEx(hwnd, hRgn, DCX_WINDOW Or DCX_INTERSECTRGN Or DCX_CLIPSIBLINGS)
        DrawBevel hdc, pic, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top, SIZE_ICON + SIZE_BORDER, SIZE_CAPTION, SIZE_BORDER, SIZE_BORDER
    Else
        hdc = GetDCEx(hwnd, 0, DCX_WINDOW Or DCX_CLIPSIBLINGS)
        ExcludeClipRect hdc, SIZE_BORDER, SIZE_CAPTION, rc.Right - rc.Left - SIZE_BORDER, _
                        rc.Bottom - rc.Top - SIZE_BORDER
        DrawBevel hdc, pic, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top, SIZE_ICON + SIZE_BORDER, SIZE_CAPTION, SIZE_BORDER, SIZE_BORDER
        SelectClipRgn hdc, 0
    End If
    
    GetButtons hwnd, Btn()
    x = rc.Right - rc.Left - SIZE_BORDER - BUT_SPACING
    y = 8 + BUT_SPACING + SIZE_BORDER
    For i = 0 To UBound(Btn)
        iw = picBut(Btn(i)).Width / 2540 * (1440 / Screen.TwipsPerPixelX)
        DrawStateButton buf2DC, x - iw, y, Btn(i), st
        x = x - iw - BUT_SPACING
        bwa = bwa + iw + BUT_SPACING
    Next
    
    capw = rc.Right - rc.Left - SIZE_BORDER * 4 - bwa - SIZE_ICON
    GetExtInfo hwnd, wi
    If GetActiveWindow() = hwnd Then Set pic = picPrg.Active Else Set pic = picPrg.Inactive
    
    If wi.ProgressState <> TBPF_NOPROGRESS Then
        DrawProgress buf2DC, SIZE_BORDER * 2 + SIZE_ICON, 8 + SIZE_BORDER, capw, pic, wi.ProgressState, wi.ProgressValue
    End If
    
    ct = GetWindowTextLength(hwnd)
    txt = Space(ct)
    GetWindowText hwnd, StrPtr(txt), ct
    SetRect rctxt, SIZE_BORDER * 3 + SIZE_ICON, 8 + SIZE_BORDER * 2, capw + SIZE_BORDER * 2 + SIZE_ICON, 8 + SIZE_CAPTION
    ofnt = SelectObject(buf2DC, capFont)
    DrawText buf2DC, StrPtr(txt), ct, rctxt, DT_END_ELLIPSIS
    SelectObject buf2DC, ofnt
    
    myDrawIcon hwnd, buf2DC
    
    BitBlt hdc, 0, 0, rc.Right - rc.Left, SIZE_CAPTION, buf2DC, 0, 0, vbSrcCopy
    
    ReleaseDC hwnd, hdc
End Function
Private Function OnTimer(ByVal hwnd As Long, ByVal ID As Long, ByVal lpTimFunc As Long) As Long
    Dim wi As WndExtInfo, hdc As Long
    If hwnd = ID Then
        GetExtInfo hwnd, wi
        wi.Icon.CurFrame = wi.Icon.CurFrame + 1
        If wi.Icon.CurFrame >= wi.Icon.NumOfFrame Then
            wi.Icon.CurFrame = 0
            If Not wi.Icon.Looped Then
                wi.Icon.State = 0
                KillTimer hwnd, ID
            End If
        End If
        SetExtInfo hwnd, wi
        myDrawIcon hwnd, buf2DC
        hdc = GetDCEx(hwnd, 0, DCX_WINDOW Or DCX_CLIPSIBLINGS)
        BitBlt hdc, SIZE_BORDER, 0, SIZE_ICON, SIZE_CAPTION, buf2DC, SIZE_BORDER, 0, vbSrcCopy
        ReleaseDC hwnd, hdc
    Else
        OnTimer = CallOldWndProc(hwnd, WM_TIMER, ID, lpTimFunc)
    End If
End Function
Private Function OnMouseMove(ByVal hwnd As Long, ByVal Btn As Long, ByVal CursorPos As Long) As Long
    Dim stat As Long, pt As POINTAPI, pos As Long, cbtn As Long, obtn As Long
    GetMem4 ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34, stat
    obtn = (stat And &HF00) \ &H100
    If obtn Then
        pt.x = IIf(CursorPos And &H8000&, CursorPos Or &HFFFF0000, CursorPos And &HFFFF&)
        pt.y = CursorPos \ &H10000
        ClientToScreen hwnd, pt
        pos = SendMessage(hwnd, WM_NCHITTEST, 0, ByVal pt.x Or (pt.y * &H10000))
        cbtn = GetBtnIndex(pos)
        UpdateButtons hwnd, pos, obtn - 1
    End If
    OnMouseMove = CallOldWndProc(hwnd, WM_MOUSEMOVE, Btn, CursorPos)
End Function
Private Function OnNCMouseLeave(ByVal hwnd As Long) As Long
    UpdateButtons hwnd, 0
End Function
Private Function OnNCMouseMove(ByVal hwnd As Long, ByVal pos As Long, ByVal CursorPos As Long) As Long
    Dim TME As tagTRACKMOUSEEVENT
    TME.cbSize = Len(TME)
    TME.dwFlags = TME_QUERY
    TrackMouseEvent TME
    If TME.hwndTrack <> hwnd Then
        TME.dwFlags = TME_LEAVE Or TME_NONCLIENT
        TME.hwndTrack = hwnd
        TrackMouseEvent TME
    End If
    UpdateButtons hwnd, pos
    OnNCMouseMove = CallOldWndProc(hwnd, WM_NCMOUSEMOVE, pos, CursorPos)
End Function
Private Function OnLButtonUp(ByVal hwnd As Long, ByVal Btn As Long, ByVal CursorPos As Long) As Long
    Dim stat As Long, pt As POINTAPI, pos As Long, btnidx As Long
    
    ReleaseCapture
    GetMem4 ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34, stat
    stat = (stat And &HF00) \ &H100
    If stat Then
        pt.x = IIf(CursorPos And &H8000&, CursorPos Or &HFFFF0000, CursorPos And &HFFFF&)
        pt.y = CursorPos \ &H10000
        ClientToScreen hwnd, pt
        pos = SendMessage(hwnd, WM_NCHITTEST, 0, ByVal pt.x Or (pt.y * &H10000))
        btnidx = GetBtnIndex(pos)
        UpdateButtons hwnd, pos, btnidx
        If stat - 1 = btnidx Then
            Select Case btnidx
            Case BUT_CLOSE: PostMessage hwnd, WM_SYSCOMMAND, SC_CLOSE, ByVal 0
            Case BUT_MAX: If IsZoomed(hwnd) Then PostMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, ByVal 0 _
                                                Else: PostMessage hwnd, WM_SYSCOMMAND, SC_MAXIMIZE, ByVal 0
            Case BUT_MIN: PostMessage hwnd, WM_SYSCOMMAND, SC_MINIMIZE, ByVal 0
            Case BUT_HELP: PostMessage hwnd, WM_SYSCOMMAND, SC_CONTEXTHELP, ByVal 0
            End Select
        End If
        GetMem4 stat And &HFF&, ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34
    End If
    OnLButtonUp = CallOldWndProc(hwnd, WM_LBUTTONUP, pos, CursorPos)
End Function
Private Function OnNCLButtonDown(ByVal hwnd As Long, ByVal pos As Long, ByVal CursorPos As Long) As Long
    Dim stat As Long, btnidx As Long, TME As tagTRACKMOUSEEVENT
    TME.cbSize = Len(TME)
    TME.dwFlags = TME_QUERY
    TrackMouseEvent TME
    If TME.hwndTrack = hwnd Then
        TME.dwFlags = TME_CANCEL Or TME_LEAVE Or TME_NONCLIENT
        TME.hwndTrack = hwnd
        TrackMouseEvent TME
    End If
    Select Case pos
    Case HTSYSMENU
        SendMessage hwnd, WM_POPUPSYSTEMMENU, 0, ByVal CursorPos
    Case HTCLOSE, HTMAXBUTTON, HTMINBUTTON, HTHELP
        GetMem4 ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34, stat
        btnidx = GetBtnIndex(pos)
        stat = stat Or (&H100& * (btnidx + 1))
        GetMem4 stat, ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34
        UpdateButtons hwnd, pos
        SetCapture hwnd
    Case Else
        OnNCLButtonDown = CallOldWndProc(hwnd, WM_NCLBUTTONDOWN, pos, CursorPos)
    End Select
End Function
Private Function OnSize(ByVal hwnd As Long, ByVal State As Long, ByVal w As Long, ByVal h As Long) As Long
    Dim hRgn1 As Long, hRgn2 As Long, rw As Long, rh As Long
    If State = SIZE_MINIMIZED Or State = SIZE_MAXIMIZED Then
        SetWindowRgn hwnd, 0, True
    Else
        rw = w + SIZE_BORDER * 2
        rh = h + SIZE_BORDER + SIZE_CAPTION
        
        hRgn1 = CreateRoundRectRgn(0, 8, rw + 1, rh + 1, 4, 4)
        hRgn2 = CreateRectRgn(4, 0, 37, 8)
        CombineRgn hRgn1, hRgn1, hRgn2, RGN_OR
        DeleteObject hRgn2
        SetWindowRgn hwnd, hRgn1, True
    End If
End Function
Private Function OnNCHitTest(ByVal hwnd As Long, ByVal x As Long, ByVal y As Long) As Long
    Dim rc As RECT, w As Long, h As Long, sizbl As Boolean, Btn() As Long, i As Long, _
        px As Long, py As Long, iw As Long, ih As Long
    
    GetWindowRect hwnd, rc
    sizbl = GetWindowLong(hwnd, GWL_STYLE) And WS_THICKFRAME
    GetButtons hwnd, Btn()
    
    x = x - rc.Left: y = y - rc.Top: w = rc.Right - rc.Left: h = rc.Bottom - rc.Top
    Select Case True
    Case x > SIZE_BORDER And x < SIZE_BORDER + SIZE_ICON And _
         y >= 0 And y < SIZE_CAPTION
        OnNCHitTest = HTSYSMENU
    
    Case x <= SIZE_BORDER And x >= 0 And sizbl
        Select Case y
        Case Is < 8: OnNCHitTest = HTTRANSPARENT
        Case Is <= 8 + SIZE_BORDER: OnNCHitTest = HTTOPLEFT
        Case Is <= h - SIZE_BORDER: OnNCHitTest = HTLEFT
        Case Else: OnNCHitTest = HTBOTTOMLEFT
        End Select
    Case x > SIZE_BORDER And x < w - SIZE_BORDER And sizbl
        Select Case y
        Case Is < 8: OnNCHitTest = HTTRANSPARENT
        Case Is <= 8 + SIZE_BORDER: OnNCHitTest = HTTOP
        Case Is <= SIZE_CAPTION: OnNCHitTest = HTCAPTION
        Case Is <= h - SIZE_BORDER: OnNCHitTest = HTCLIENT
        Case Else: OnNCHitTest = HTBOTTOM
        End Select
    Case x >= w - SIZE_BORDER And x <= w And sizbl
        Select Case y
        Case Is < 8: OnNCHitTest = HTTRANSPARENT
        Case Is <= 8 + SIZE_BORDER: OnNCHitTest = HTTOPRIGHT
        Case Is <= h - SIZE_BORDER: OnNCHitTest = HTRIGHT
        Case Else: OnNCHitTest = HTBOTTOMRIGHT
        End Select
    End Select
    If OnNCHitTest = 0 Or OnNCHitTest = HTCAPTION Then
        px = w - SIZE_BORDER - BUT_SPACING: py = 8 + BUT_SPACING + SIZE_BORDER
        If y >= py Then
            For i = 0 To UBound(Btn)
                iw = picBut(Btn(i)).Width / 2540 * (1440 / Screen.TwipsPerPixelX)
                ih = picBut(Btn(i)).Height / 2540 * (1440 / Screen.TwipsPerPixelY) \ 5
                If x >= px - iw And x <= px And y <= py + ih Then
                    Select Case i
                    Case BUT_CLOSE: OnNCHitTest = HTCLOSE
                    Case BUT_MAX: OnNCHitTest = HTMAXBUTTON
                    Case BUT_MIN: OnNCHitTest = HTMINBUTTON
                    Case BUT_HELP: OnNCHitTest = HTHELP
                    End Select
                    Exit Function
                End If
                px = px - iw - BUT_SPACING
            Next
            OnNCHitTest = HTCAPTION
        End If
    End If
End Function
Private Function OnNCActivate(ByVal hwnd As Long, ByVal State As Boolean) As Long
    RedrawWindow hwnd, ByVal 0, 0, RDW_FRAME Or RDW_INVALIDATE
    OnNCActivate = 1
End Function
Private Function OnNCCalcSize(ByVal hwnd As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim cs As NCCALCSIZE_PARAMS
    If wParam = 0 Then Exit Function
    CopyMemory cs, ByVal lParam, Len(cs)
    With cs.rgrc(0)
    .Left = .Left + SIZE_BORDER
    .Right = .Right - SIZE_BORDER
    .Bottom = .Bottom - SIZE_BORDER
    .Top = .Top + SIZE_CAPTION
    End With
    CopyMemory ByVal lParam, cs, Len(cs)
End Function
Private Sub UpdateButtons(ByVal hwnd As Long, ByVal pos As Long, Optional Button As Long = -1)
    Dim stat As Long, Btn() As Long, i As Long, msk() As Long, lst As Long, cst As Long, prs As Long, _
        cbtn As Long, b As Long, x As Long, y As Long, rc As RECT, iw As Long, hdc As Long, st As Long, _
        nstat As Long
    
    GetWindowRect hwnd, rc
    hdc = GetDCEx(hwnd, 0, DCX_WINDOW Or DCX_CLIPSIBLINGS)
    GetMem4 ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34, stat
    GetButtons hwnd, Btn()
    prs = (GetKeyState(VK_LBUTTON) And &H8000&) \ &H8000&
    ReDim msk(3): msk(0) = 1
    For i = 1 To UBound(msk)
        msk(i) = (msk(i - 1)) * 4
    Next
    cst = prs + 1
    cbtn = GetBtnIndex(pos)
    For i = 0 To UBound(Btn)
        lst = stat \ msk(Btn(i))
        If Button = -1 Or (Button = Btn(i)) Then
            If (Btn(i) = cbtn And lst <> cst) Or (Btn(i) <> cbtn And lst <> 0) Then
                x = (rc.Right - rc.Left) - SIZE_BORDER
                y = 8 + BUT_SPACING + SIZE_BORDER
                b = 0
                Do
                    iw = picBut(Btn(b)).Width / 2540 * (1440 / Screen.TwipsPerPixelX)
                    x = x - iw - BUT_SPACING
                    b = b + 1
                Loop Until b > Btn(i)
                If (Btn(i) = cbtn And lst <> cst) Then
                    Select Case cst
                    Case 0: st = IIf(GetActiveWindow() = hwnd, 0, 3)
                    Case 1: st = IIf(GetActiveWindow() = hwnd, 2, 4)
                    Case 2: st = 1
                    End Select
                    lst = cst
                Else
                    lst = 0
                    st = IIf(GetActiveWindow() = hwnd, 0, 3)
                End If
                DrawStateButton hdc, x, y, Btn(i), st
            End If
        End If
        nstat = nstat Or (lst * msk(Btn(i)))
    Next
    nstat = nstat Or (stat And &HF00&)
    ReleaseDC hwnd, hdc
    GetMem4 nstat, ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34
End Sub
Private Sub GetButtons(ByVal hwnd As Long, but() As Long)
    Dim sty As Long, esty As Long, i As Long
    
    ReDim but(3)
    but(i) = BUT_CLOSE: i = i + 1
 
    sty = GetWindowLong(hwnd, GWL_STYLE)
    esty = GetWindowLong(hwnd, GWL_EXSTYLE)
    
    If sty And WS_MAXIMIZEBOX Then but(i) = BUT_MAX: i = i + 1
    If sty And WS_MINIMIZEBOX Then but(i) = BUT_MIN: i = i + 1
    If esty And WS_EX_CONTEXTHELP Then but(i) = BUT_HELP: i = i + 1
    
    ReDim Preserve but(i - 1)
End Sub
Private Function GetBtnState(ByVal hwnd As Long, ByVal BtnIndex As Long) As Long
    Dim stat As Long, m As Long, i As Long
    GetMem4 ByVal GetWindowLong(hwnd, GWL_USERDATA) + 34, stat
    m = 1
    For i = 0 To BtnIndex: m = m * 4: Next
    stat = (stat \ m) And 3
End Function
Private Function GetBtnIndex(ByVal pos As Long) As Long
    Select Case pos
    Case HTCLOSE: GetBtnIndex = BUT_CLOSE
    Case HTMAXBUTTON:  GetBtnIndex = BUT_MAX
    Case HTMINBUTTON:  GetBtnIndex = BUT_MIN
    Case HTHELP:  GetBtnIndex = BUT_HELP
    Case Else: GetBtnIndex = -1
    End Select
End Function
Private Function GetBtnAreaWidth(ByVal hwnd As Long) As Long
    Dim Btn() As Long, i As Long
    GetButtons hwnd, Btn()
    For i = 0 To UBound(Btn)
        GetBtnAreaWidth = GetBtnAreaWidth + picBut(Btn(i)).Width / 2540 * (1440 / Screen.TwipsPerPixelX) + BUT_SPACING
    Next
End Function
Private Sub DrawBevel(ByVal hdc As Long, bmp As StdPicture, ByVal x As Long, ByVal y As Long, _
                      ByVal w As Long, ByVal h As Long, ByVal l As Long, ByVal t As Long, _
                      ByVal r As Long, ByVal b As Long)
    Dim obmp As Long, iw As Long, ih As Long, X1 As Long, Y1 As Long
    
    iw = bmp.Width / 2540 * (1440 / Screen.TwipsPerPixelX)
    ih = bmp.Height / 2540 * (1440 / Screen.TwipsPerPixelY)
    X1 = iw - r: Y1 = ih - b
    
    obmp = SelectObject(bufDC, bmp.Handle)
    
    BitBlt buf2DC, x, y, l, t, bufDC, 0, 0, vbSrcCopy
    StretchBlt buf2DC, x + l, y, w - l - r, t, bufDC, l, 0, iw - l - r, t, vbSrcCopy
    BitBlt buf2DC, x + w - r, y, r, t, bufDC, X1, 0, vbSrcCopy
    StretchBlt hdc, x, y + t, l, h - t - b, bufDC, 0, t, l, ih - t - b, vbSrcCopy
    StretchBlt hdc, x + w - r, y + t, r, h - t - b, bufDC, X1, t, r, ih - t - b, vbSrcCopy
    BitBlt hdc, x, y + h - b, l, b, bufDC, 0, Y1, vbSrcCopy
    StretchBlt hdc, x + l, y + h - b, w - l - r, b, bufDC, l, Y1, iw - l - r, b, vbSrcCopy
    BitBlt hdc, x + w - r, y + h - b, r, b, bufDC, X1, Y1, vbSrcCopy
    SelectObject bufDC, obmp
End Sub
Private Sub DrawStateButton(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal Button As Long, ByVal State As Long)
    Dim iw As Long, ih As Long, bmp As StdPicture, obmp As Long
 
    Set bmp = picBut(Button)
    iw = bmp.Width / 2540 * (1440 / Screen.TwipsPerPixelX)
    ih = bmp.Height / 2540 * (1440 / Screen.TwipsPerPixelY) / 5
    obmp = SelectObject(bufDC, bmp.Handle)
    BitBlt hdc, x, y, iw, ih, bufDC, 0, ih * State, vbSrcCopy
    
    SelectObject bufDC, obmp
End Sub
Private Sub DrawProgress(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal w As Long, _
                         ByVal bmp As StdPicture, ByVal State As Long, ByVal Value As Single, _
                         Optional ByVal bx As Long = 4)
    Dim iw As Long, ih As Long, sy As Long, obmp As Long, pw As Long
    
    iw = bmp.Width / 2540 * (1440 / Screen.TwipsPerPixelX)
    ih = bmp.Height / 2540 * (1440 / Screen.TwipsPerPixelY) / 4
    obmp = SelectObject(bufDC, bmp.Handle)
    Select Case State
    Case Taskbarlib.TBPFLAG.TBPF_NORMAL: sy = ih * 1
    Case Taskbarlib.TBPFLAG.TBPF_PAUSED: sy = ih * 2
    Case Taskbarlib.TBPFLAG.TBPF_ERROR: sy = ih * 3
    End Select
    pw = Value * w
    IntersectClipRect hdc, x, y, x + pw, y + ih
    BitBlt hdc, x, y, bx, ih, bufDC, 0, sy, vbSrcCopy
    StretchBlt hdc, x + bx, y, w - bx * 2, ih, bufDC, bx, sy, iw - bx * 2, ih, vbSrcCopy
    BitBlt hdc, x + w - bx, y, bx, ih, bufDC, iw - bx, sy, vbSrcCopy
    SelectClipRgn hdc, 0
    IntersectClipRect hdc, x + pw, y, x + w, y + ih
    BitBlt hdc, x, y, bx, ih, bufDC, 0, 0, vbSrcCopy
    StretchBlt hdc, x + bx, y, w - bx * 2, ih, bufDC, bx, 0, iw - bx * 2, ih, vbSrcCopy
    BitBlt hdc, x + w - bx, y, bx, ih, bufDC, iw - bx, 0, vbSrcCopy
    SelectClipRgn hdc, 0
    SelectObject bufDC, obmp
End Sub
Private Sub InvalidateProgress(ByVal hwnd As Long)
    Dim bwa As Long, rc As RECT
    bwa = GetBtnAreaWidth(hwnd)
    GetWindowRect hwnd, rc
    SetRect rc, SIZE_ICON + SIZE_BORDER, -SIZE_CAPTION, rc.Right - rc.Left - bwa - SIZE_BORDER * 2, 0
    RedrawWindow hwnd, rc, 0, RDW_FRAME Or RDW_INVALIDATE ' Or RDW_UPDATENOW
End Sub
Private Sub myDrawIcon(ByVal hwnd As Long, ByVal hdc As Long)
    Dim wi As WndExtInfo, hIcon As Long, iw As Long, ih As Single, ct As Long, x As Long, y As Long, a As Single, d As Single, _
        obmp As Long, pic As StdPicture, icn As StdPicture, rw As Long, rh As Long
    GetExtInfo hwnd, wi
    If wi.Icon.Sequence = 0 Then
        hIcon = SendMessage(hwnd, WM_GETICON, ICON_BIG, ByVal 0)
        DrawIconEx hdc, SIZE_BORDER + 2, 2, hIcon, SIZE_ICON - 4, SIZE_ICON - 4, 0, 0, 3
    Else
        ct = wi.Icon.NumOfFrame
        vbaObjSet icn, ByVal wi.Icon.Sequence
        If ct <= 0 Then ct = 1
        rw = icn.Width / 2540 * (1440 / Screen.TwipsPerPixelX)
        rh = icn.Height / 2540 * (1440 / Screen.TwipsPerPixelY) / ct
        a = rw / rh
        If a > 1 Then
            If rw > SIZE_ICON - 4 Then d = (SIZE_ICON - 4) / rw Else d = 1
        Else: If rh > SIZE_ICON - 4 Then d = (SIZE_ICON - 4) / rh Else d = 1
        End If
        iw = rw * d
        ih = rh * d
        x = ((SIZE_ICON - 4) - iw) \ 2 + SIZE_BORDER + 2
        y = ((SIZE_CAPTION - 4) - ih) \ 2 + 2
        If GetActiveWindow() = hwnd Then Set pic = picWnd.Active Else Set pic = picWnd.Inactive
        Debug.Print x, y, rw, rh
        obmp = SelectObject(bufDC, pic.Handle)
        BitBlt hdc, SIZE_BORDER, 0, SIZE_ICON, SIZE_CAPTION, bufDC, SIZE_BORDER, 0, vbSrcCopy
        SelectObject bufDC, icn.Handle
        AlphaBlend hdc, x, y, iw, ih, bufDC, 0, rh * wi.Icon.CurFrame, rw, rh, AB_32Bpp255
        SelectObject bufDC, obmp
        GetMem4 0, icn
    End If
End Sub

Option Explicit
 
' Тестовая форма модуля пользовательской отрисовки окна
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Dim Value As Single
 
Private Sub cboIcon_Click()
    Select Case cboIcon.ListIndex
    Case 0: SetIcon Me, LoadResPicture("TRICKICON", vbResBitmap), 21
    Case 1: SetIcon Me, LoadResPicture("WAITICON", vbResBitmap), 20
    End Select
End Sub
 
Private Sub cmdDuplicate_Click()
    Dim frm As frmTest
    Set frm = New frmTest
    frm.Show
End Sub
 
Private Sub cmdHideProgress_Click()
    SetProgressState Me, TBPF_NOPROGRESS
End Sub
 
Private Sub cmdIcon_Click()
    PlayAnimation Me, 32, False
End Sub
Private Sub cmdIconLoop_Click()
    PlayAnimation Me, 32, True
End Sub
Private Sub cmdProgress_Click()
    tmrTimer.Enabled = True
    Value = 0
End Sub
Private Sub cmdShowProgress_Click()
    If optState(0).Value Then SetProgressState Me, TBPF_NORMAL
    If optState(1).Value Then SetProgressState Me, TBPF_PAUSED
    If optState(2).Value Then SetProgressState Me, TBPF_ERROR
End Sub
Private Sub cmdStopAnimation_Click()
    StopAnimation Me
End Sub
Private Sub cmdStopProgress_Click()
    tmrTimer.Enabled = False
End Sub
Private Sub Form_Load()
    SetNCSkin Me
    cboIcon.ListIndex = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
    RemoveNCSkin Me
End Sub
Private Sub optState_Click(Index As Integer)
    Call cmdShowProgress_Click
End Sub
 
Private Sub tmrTimer_Timer()
    Value = Value + 0.01
    SetProgressValue Me, Value
End Sub