الفريق العربي للهندسة العكسية

 { 
  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.