PUBLIC oForm As Tform
oForm = CREATEOBJECT("Tform")
oForm.Visible=.T.
* end of main
 
DEFINE CLASS Tform As Form
    Width=500
    Height=350
    Caption="Test form"
*    ShowWindow=2
    Autocenter=.T.
 
    ADD OBJECT cmd As CommandButton WITH Left=210, Top=310,;
    Width=80, Height=27, Caption="Close"
 
PROCEDURE cmd.Click
    ThisForm.Release
 
PROCEDURE Destroy
    IF VARTYPE(_screen.FormFader1) <> "O"
        _screen.AddObject("FormFader1", "FormFader")
    ENDIF
    _screen.FormFader1.FadeWindow(THIS)
 
ENDDEFINE
 
DEFINE CLASS FormFader As Container
#DEFINE SRCCOPY 0x00CC0020
#DEFINE DWORD_MAX_VALUE 0xffffffff
#DEFINE WS_VISIBLE 0x10000000
#DEFINE WS_DISABLED 0x08000000
#DEFINE WS_EX_LAYERED 0x80000
#DEFINE WS_EX_NOACTIVATE 0x8000000
#DEFINE SM_CYCAPTION 4
#DEFINE SM_CXFRAME 32
#DEFINE SM_CYFRAME 33
#DEFINE LWA_ALPHA 2
#DEFINE GWL_EXSTYLE -20
#DEFINE GWL_STYLE -16
#DEFINE TIMER_INTERVAL 10
#DEFINE ALPHA_MIN_VALUE 4
#DEFINE ALPHA_DECREASE_BY 4
 
    Visible=.F.
    fadingwindows=NULL
    gdiplus=NULL
    ADD OBJECT Timer1 As Timer
 
PROCEDURE Init
    SET PROCEDURE TO gdiplus ADDITIVE
    THIS.gdiplus = CREATEOBJECT("gdiplusinit")
    THIS.declare
    THIS.fadingwindows = CREATEOBJECT("Collection")
 
PROCEDURE Destroy
    THIS.Timer1.Interval=0
    IF VARTYPE(THIS.fadingwindows) = "O"
        DO WHILE THIS.fadingwindows.Count > 0
            THIS.fadingwindows.Remove(1)
        ENDDO
    ENDIF
    THIS.gdiplus=NULL
 
PROCEDURE FadeWindow(oForm As Form)
    LOCAL fw As FadingWindow
    fw = CREATEOBJECT("FadingWindow", oForm.HWnd)
    THIS.fadingwindows.Add(m.fw)
    THIS.Timer1.Interval=TIMER_INTERVAL
 
PROCEDURE Timer1.Timer
    THIS.Parent.DrawWindows
 
PROCEDURE DrawWindows
    LOCAL fw As FadingWindow
    FOR EACH fw IN THIS.fadingwindows
        IF fw.DrawBackground <= ALPHA_MIN_VALUE
            THIS.RemoveWindow(m.fw)
            IF THIS.fadingwindows.Count = 0
                THIS.Timer1.Interval=0
            ENDIF
        ENDIF
    NEXT
 
PROCEDURE RemoveWindow(fw As FadingWindow)
    LOCAL fw As FadingWindow, nIndex
    WITH THIS.fadingwindows
        FOR nIndex=1 TO .Count
            IF .Item(m.nIndex).hCoverWindow = fw.hCoverWindow
                .Remove[m.nIndex]
                EXIT
            ENDIF
        NEXT
    ENDWITH
 
PROCEDURE declare
    DECLARE INTEGER DestroyWindow IN user32 INTEGER hWindow
    DECLARE INTEGER IsWindow IN user32 INTEGER hWindow
    DECLARE INTEGER GetWindowDC IN user32 INTEGER hwindow
    DECLARE INTEGER ReleaseDC IN user32 INTEGER hwindow, INTEGER hdc
    DECLARE INTEGER GetWindowRect IN user32 INTEGER hwnd, STRING @lpRect 
    DECLARE INTEGER GetSystemMetrics IN user32 INTEGER nIndex
    DECLARE INTEGER GetWindowLong IN user32 INTEGER hWindow, INTEGER nIndex
 
    DECLARE INTEGER SetWindowLong IN user32;
        INTEGER hWindow, INTEGER nIndex, INTEGER dwNewLong
 
    DECLARE INTEGER CreateRectRgn IN gdi32;
        INTEGER nLeftRect, INTEGER nTopRect,;
        INTEGER nRightRect, INTEGER nBottomRect
 
    DECLARE INTEGER SetWindowRgn IN user32;
        INTEGER hWindow, INTEGER hRgn, SHORT bRedraw
 
    DECLARE INTEGER RealGetWindowClass IN user32;
        INTEGER hWindow, STRING @pszType, INTEGER cchType
 
    DECLARE INTEGER BitBlt IN gdi32;
        INTEGER hDestDC, INTEGER x, INTEGER y,;
        INTEGER nWidth, INTEGER nHeight, INTEGER hSrcDC,;
        INTEGER xSrc, INTEGER ySrc, INTEGER dwRop
 
    DECLARE INTEGER CreateWindowEx IN user32;
        INTEGER dwExStyle, STRING lpClassName, STRING lpWindowName,;
        INTEGER dwStyle, INTEGER x, INTEGER y,;
        INTEGER nWidth, INTEGER nHeight, INTEGER hWndParent,;
        INTEGER hMenu, INTEGER hInstance, INTEGER lpParam
 
    DECLARE INTEGER SetLayeredWindowAttributes IN user32;
        INTEGER hWindow, INTEGER crKey,;
        SHORT bAlpha, INTEGER dwFlags
 
ENDDEFINE
 
DEFINE CLASS FadingWindow As Session
    hOrigWindow=0 && HWND of the original form
    hCoverWindow=0 && HWND of the covering window
    * coordinates of the original form
    winleft=0
    wintop=0
    winwidth=0
    winheight=0
    * coordinates of the covering window
    cwinleft=0
    cwintop=0
    cwinwidth=0
    cwinheight=0
 
    origbmp=NULL  && gdi+ bitmap storing the form`s image
    hgraphics=NULL && gdi+ graphics object
    alphachannel=0xff  && alpha channel value
 
PROCEDURE Init(hOrigWindow As Integer)
    THIS.hOrigWindow = m.hOrigWindow
    IF IsWindow(THIS.hOrigWindow) = 0
        RETURN .F.
    ENDIF
    THIS.CopyWinImage
    THIS.CreateCoveringWindow
 
PROCEDURE Destroy
    IF NOT ISNULL(THIS.hGraphics)
        THIS.hGraphics=NULL
    ENDIF
    THIS.DestroyCoverWindow
    THIS.origbmp=NULL
 
PROCEDURE DestroyCoverWindow
    IF THIS.hCoverWindow <> 0 
        IF IsWindow(THIS.hCoverWindow) <> 0
            = DestroyWindow(THIS.hCoverWindow)
        ENDIF
        THIS.hCoverWindow=0
    ENDIF
 
PROTECTED PROCEDURE CopyWinImage
* copies the image of the original form to gdi+ bitmap
    LOCAL hdc
    hdc = GetWindowDC(THIS.hOrigWindow)
 
    WITH THIS
        .GetWinRect
        .origbmp = CREATEOBJECT("gdibitmap", .winwidth, .winheight)
        WITH .origbmp
            .graphics.GetDC
            = BitBlt(.graphics.hdc, 0,0, .imgwidth, .imgheight,;
                m.hdc, 0,0, SRCCOPY)
            .graphics.ReleaseDC
        ENDWITH
        = ReleaseDC(.hOrigWindow, m.hdc)
    ENDWITH
 
PROTECTED PROCEDURE CreateCoveringWindow
    LOCAL nExStyle, cClass, nStyle, hParent, nCaptionHeight,;
        nFrameWidth, nFrameHeight, x1, y1, x2, y2, hRgnBase
 
    hParent = application.hWnd && _screen.HWnd
    cClass = THIS.GetWinClass(m.hParent) && to be continued
    nStyle = WS_VISIBLE
    nExStyle = BITOR(WS_EX_NOACTIVATE, WS_EX_LAYERED)
 
    nCaptionHeight = GetSystemMetrics(SM_CYCAPTION)
    nFrameWidth = GetSystemMetrics(SM_CXFRAME)
    nFrameHeight = GetSystemMetrics(SM_CYFRAME)
 
    THIS.cwinleft=THIS.winleft-m.nFrameWidth
    THIS.cwintop=THIS.wintop-m.nFrameHeight-m.nCaptionHeight
    THIS.cwinwidth=THIS.winwidth+m.nFrameWidth*2
    THIS.cwinheight=THIS.winheight+m.nCaptionHeight+m.nFrameHeight*2
 
    THIS.hCoverWindow = CreateWindowEx(nExStyle, cClass, NULL, nStyle,;
        THIS.cwinleft, THIS.cwintop, THIS.cwinwidth, THIS.cwinheight,;
        hParent, 0,0,0)
 
    IF THIS.hCoverWindow = 0
        RETURN .F.
    ENDIF
 
    * cut the caption and the frame off the covering window
    * by creating and applying a rectangular frame
    x1 = nFrameWidth
    y1 = nFrameHeight+nCaptionHeight
    x2 = THIS.cwinwidth-nFrameWidth
    y2 = THIS.cwinheight-nFrameHeight
 
    hRgnBase = CreateRectRgn(x1, y1, x2, y2)
    = SetWindowRgn(THIS.hCoverWindow, m.hRgnBase, 1)
    = DeleteObject(m.hRgnBase)
 
    * use HWND of the covering window for creating 
    * GDI+ graphics object
    THIS.hGraphics = CREATEOBJECT("graphics", THIS.hCoverWindow)
 
PROCEDURE DrawBackground
* draws the image of the original form on the covering window
* at the same time increasing its transparency
    IF THIS.alphachannel > ALPHA_MIN_VALUE
        THIS.alphachannel = THIS.alphachannel - ALPHA_DECREASE_BY
    ENDIF
    = SetLayeredWindowAttributes(THIS.hCoverWindow, 0,;
        THIS.alphachannel, LWA_ALPHA)
    THIS.hGraphics.drawimage(THIS.origbmp,;
        1, 1, THIS.winwidth, THIS.winheight)
RETURN THIS.alphachannel
 
PROTECTED PROCEDURE GetWinClass(hParent)
    LOCAL cClass, nSize
    cClass = REPLICATE(CHR(0), 250)
    nSize = RealGetWindowClass(hParent, @cClass , Len(cClass ))
RETURN STRTRAN(SUBSTR(cClass, 1, nSize), CHR(0),"")
 
PROTECTED PROCEDURE GetWinRect
    LOCAL oRect As Rect, cBuffer
    oRect = CREATEOBJECT("Rect", 0,0,0,0)
    cBuffer = oRect.ToString()
    = GetWindowRect(THIS.hOrigWindow, @cBuffer)
    oRect.FromString1(m.cBuffer)
 
    WITH THIS
        .winleft = oRect.rleft
        .wintop = oRect.rtop
        .winwidth = oRect.rwidth
        .winheight = oRect.rheight
    ENDWITH
 
ENDDEFINE