| Sn!per X |
01-15-2016 23:10 |
[Delphi] Flicker Free Text Scrolling with Double Buffering
1 Attachment(s)
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.
|
