delphi4arab منتديات دلفي للعرب - Flicker Free Text Scrolling with Double Buffering

السلام عليكم

[صورة: image.gif]
PHP كود :
{
  Flicker Free Text Scrolling with Double Buffering
  Original C++ Source: http://www.codeproject.com/Tips/610388/Flicker-Free-Text-Scrolling-with-Double-Buffering
  Converted to Delphi by Agmcz  
  Rlz Date: 17-12-2015
}

program w32;
          
uses
  Windows, Messages;

{$R w32.RES}

const
  IDD_DIALOG1 = 101;
  IDB_BITMAP1 = 102;

var
  hIns: HINST;
  hSkin: HBITMAP;
  rcClient, rcText: TRect;
  nLines: Integer = 0;
  TextLen: Integer = 0;
  lf: LOGFONT;
  _hFont: HFONT;
  ScrollConst: Integer = 1;
  CLR: COLORREF;
  cx, cy: LongInt;
  hdcBackground: HDC;
  ndcBackground: Integer;
const
  Text = 'Simple flicker free text scrolling' + #13#10 +
    'Coded by Tejashwi Kalp Taru' + #13#10 + #13#10 + 'Enjoy the double buffer'
      +
    #13#10 + #13#10 + 'Thanks to codeproject.com for a nice place' + #13#10 +
    'for developer to developer';

function DlgProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL
  stdcall;
var
  bm: BITMAP;
  hdcScreen: HDC;
  i: Integer;
  sizeAboutText: TSIZE;
  _hDC: HDC;
  hDCMem: HDC;
  ps: PAINTSTRUCT;
  ndcmem: Integer;
  hbmMem: HBITMAP;
begin
  case Msg of
    WM_INITDIALOG:
      begin
        // Loads the bitmap, get its CX,CY and get compatibe device context
        hSkin := LoadBitmap(hIns, MAKEINTRESOURCE(IDB_BITMAP1));
        GetObject(hSkin, sizeof(bm), @bm);
        cx := bm.bmWidth;
        cy := bm.bmHeight;
        hdcScreen := GetDC(hWnd);
        hdcBackground := CreateCompatibleDC(hdcScreen);
        ndcBackground := SaveDC(hdcBackground);
        SelectObject(hdcBackground, hSkin);
        ReleaseDC(hWnd, hdcScreen);
        //------------------------------------------------------------------

        // Counts the number of lines in scroll text
        TextLen := lstrlen(Text);
        for i := 1 to TextLen do
        begin
          if (Text[i] = #13#10) then
            Inc(nLines);
        end;
        //------------------------------------------

        // Create a font as desired
        ZeroMemory(@lf, sizeof(LOGFONT));
        lstrcpy(lf.lfFaceName, 'Lucida Console');
        lf.lfHeight := 20;
        lf.lfWeight := FW_BOLD;
        lf.lfQuality := ANTIALIASED_QUALITY;
        _hFont := CreateFontIndirect(lf);
        GetClientRect(hWnd, rcClient);
        //-----------------------------------

        // Gets the size of total scroll texts
        _hDC := GetDC(hWnd);
        hDCMem := CreateCompatibleDC(_hDC);
        SelectObject(hDCMem, _hFont);
        GetTextExtentPoint32A(hDCMem, Text, TextLen, sizeAboutText);
        ReleaseDC(hWnd, _hDC);
        DeleteDC(hDCMem);
        //-----------------------------------------------------------

        // Calculates the needed size for given scroller text
        rcText.bottom := rcText.bottom + (sizeAboutText.cy * (nLines + 3)) +
          rcClient.bottom;
        rcText.top := rcClient.bottom;
        rcText.right := rcClient.right;
        rcText.left := rcClient.left;
        //----------------------------------------------------------------

        SetTimer(hWnd, 1, 20, 0); // Starts timer of duration of 20MS
        Result := True;
      end;
    WM_TIMER:
      begin
        // Check and set the current range of scroll text and sets color of text accordingly
        rcText.top := rcText.top + ScrollConst;
        rcText.bottom := rcText.bottom + ScrollConst;
        if (rcText.top >= rcClient.bottom + 10) then
        begin
          ScrollConst := -1;
          CLR := RGB(0, 0, 255);
        end;
        if (rcText.bottom <= rcClient.top) then
        begin
          ScrollConst := 1;
          CLR := RGB(255, 0, 0);
        end;
        //-----------------------------------------------------------------------------------
        InvalidateRect(hWnd, nil, False);
        // Invalidates the window, WM_PAINT caused !!!
        Result := True;
      end;
    WM_PAINT:
      begin
        if BeginPaint(hWnd, ps) > 0 then
        begin
          //Creating double buffer
          hdcMem := CreateCompatibleDC(ps.hdc);
          ndcmem := SaveDC(hdcMem);
          hbmMem := CreateCompatibleBitmap(ps.hdc, cx, cy);
          SelectObject(hdcMem, hbmMem);
          //-------------------------------------------------------

          // Copy background bitmap into double buffer
          BitBlt(hdcMem, 0, 0, cx, cy, hdcBackground, 0, 0, SRCCOPY);
          //---------------------------------------------------------

          // Draw the text
          SelectObject(hdcMem, _hFont);
          SetTextColor(hdcMem, CLR);
          SetBkMode(hdcMem, TRANSPARENT);
          DrawText(hdcMem, Text, -1, rcText, DT_CENTER or DT_TOP or DT_NOPREFIX
            or DT_NOCLIP);
          //-----------------------------------------------------------------------------

          // Copy double buffer to screen
          BitBlt(ps.hdc, 0, 0, cx, cy, hdcMem, 0, 0, SRCCOPY);
          //--------------------------------------------------

          // Clean up
          RestoreDC(hdcMem, ndcmem);
          DeleteObject(hbmMem);
          DeleteDC(hdcMem);
          EndPaint(hWnd, ps);
          //--------------------
        end
        else
        begin
          KillTimer(hWnd, 1);
          MessageBox(hWnd,
            'Unable to render graphics' + #13#10 +
              'Error : Can not start painting!', 'Error',
            MB_ICONERROR);
        end;
        Result := True;
      end;
    WM_CLOSE:
      begin
        KillTimer(hWnd, 1);
        RestoreDC(hdcBackground, ndcBackground);
        DeleteDC(hdcBackground);
        DeleteObject(hSkin);
        DeleteObject(_hFont);
        EndDialog(hWnd, 0);
        Result := True;
      end;
  end;
  Result := False;
end;

begin
  hIns := hInstance;
  DialogBoxParam(hInstance, PChar(IDD_DIALOG1), 0, @DlgProc, 0);
end.   