EXETOOLS FORUM  

Go Back   EXETOOLS FORUM > General > Source Code

Notices

Reply
 
Thread Tools Display Modes
  #1  
Old 01-15-2016, 23:10
Sn!per X Sn!per X is offline
Friend
 
Join Date: Nov 2015
Location: AT4RE
Posts: 21
Rept. Given: 0
Rept. Rcvd 12 Times in 6 Posts
Thanks Given: 8
Thanks Rcvd at 43 Times in 10 Posts
Sn!per X Reputation: 12
Lightbulb [Delphi] Flicker Free Text Scrolling with Double Buffering

http://s19.postimg.org/69f4hvu4j/image.gif
Code:
{ 
  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.
Attached Files
File Type: rar Text Scrolling source code.rar (156.3 KB, 23 views)
Reply With Quote
Reply

Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is On



All times are GMT +8. The time now is 10:07.


��ICP��05004977��
Always Your Best Friend: Aaron, JMI, ahmadmansoor, ZeNiX