paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-03 02:58:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

win32: make DrawDefaultDockImage more windows like

Browse Source 
git-svn-id: trunk@14372 -
This commit is contained in:
paul 2008-03-03 06:38:54 +00:00
parent bf42bc94f5
commit 921cee3b57
5 changed files with 64 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lcl/include/intfbaselcl.inc
View File

@ -144,7 +144,7 @@ procedure TWidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation:
procedure DefaultDockImage(ARect: TRect);
const
PenSize=4;
PenSize = 4;
var
DC: HDC;
OldPen, NewPen: HPen;
@ -162,9 +162,9 @@ procedure TWidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation:
with ARect do
begin
MoveToEx(DC, Left+PenSize, Top+PenSize, nil);
LineTo(DC, Right-PenSize,Top+PenSize);
LineTo(DC, Right-PenSize, Top+PenSize);
LineTo(DC, Right-PenSize, Bottom-PenSize);
LineTo(DC, Left+PenSize,Bottom-PenSize);
LineTo(DC, Left+PenSize, Bottom-PenSize);
LineTo(DC, Left+PenSize, Top+PenSize);
end;
finally

5
lcl/interfaces/win32/win32int.pp
View File

@ -157,8 +157,10 @@ type
InitCommonControlsEx: function(ICC: PInitCommonControlsEx): LongBool; stdcall;
FOnAsyncSocketMsg: TSocketEvent;
FDotsPatternBitmap: HBitmap;
procedure AssignSelf(Window: HWnd; Data: Pointer);
function GetDotsPatternBitmap: HBitmap;
{ event handler helper functions }
procedure HandleProcessEvent(AData: PtrInt; AFlags: dword);
@ -187,7 +189,7 @@ type
procedure AppBringToFront; override;
procedure AppProcessMessages; override;
procedure AppWaitMessage; override;
Procedure AppTerminate; Override;
Procedure AppTerminate; override;
procedure AppSetTitle(const ATitle: string); override;
function InitHintFont(HintFont: TObject): Boolean; Override;
@ -214,6 +216,7 @@ type
//property MessageFont: HFONT read FMessageFont;
property CommonControlsVersion: DWord read FCommonControlsVersion;
property OnAsyncSocketMsg: TSocketEvent read FOnAsyncSocketMsg write FOnAsyncSocketMsg;
property DotsPatternBitmap: HBitmap read GetDotsPatternBitmap;
end;
{$I win32listslh.inc}

43
lcl/interfaces/win32/win32lclintf.inc
View File

@ -272,6 +272,49 @@ begin
DFC_SCROLL, ArrowTypeToState[TArrow(Arrow).ArrowType]);
end;
procedure TWin32WidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation);
const
LineSize = 4;
procedure DrawHorzLine(DC: HDC; x1, x2, y: integer);
begin
PatBlt(DC, x1, y, x2 - x1, LineSize, PATINVERT);
end;
procedure DrawVertLine(DC: HDC; y1, y2, x: integer);
begin
PatBlt(DC, x, y1, LineSize, y2 - y1, PATINVERT);
end;
procedure DefaultDockImage(ARect: TRect);
var
DC: HDC;
NewBrush, OldBrush: HBrush;
begin
DC := GetDCEx(0, 0, DCX_LOCKWINDOWUPDATE); // drawing during tracking
try
NewBrush := CreatePatternBrush(Win32WidgetSet.DotsPatternBitmap);
OldBrush := SelectObject(DC, NewBrush);
with ARect do
begin
DrawHorzLine(DC, Left, Right, Top);
DrawVertLine(DC, Top + LineSize, Bottom - LineSize, Left);
DrawHorzLine(DC, Left, Right, Bottom - LineSize);
DrawVertLine(DC, Top + LineSize, Bottom - LineSize, Right - LineSize);
end;
DeleteObject(SelectObject(DC, OldBrush));
finally
ReleaseDC(0, DC);
end;
end;
begin
if AOperation in [disMove, disHide] then
DefaultDockImage(AOldRect);
if AOperation in [disMove, disShow] then
DefaultDockImage(ANewRect);
end;
{------------------------------------------------------------------------------
Function: GetAcceleratorString
Params: AVKey:

1
lcl/interfaces/win32/win32lclintfh.inc
View File

@ -41,6 +41,7 @@ function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
procedure DeallocateHWnd(Wnd: HWND); override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); override;
function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect;
Str: PChar; Count: Longint; Dx: PInteger): Boolean; override;

13
lcl/interfaces/win32/win32object.inc
View File

@ -42,6 +42,7 @@ begin
OnClipBoardRequest := nil;
Pointer(InitCommonControlsEx) := GetProcAddress(GetModuleHandle(comctl32), 'InitCommonControlsEx');
FCommonControlsVersion := GetFileVersion(comctl32);
FDotsPatternBitmap := 0;
end;
{------------------------------------------------------------------------------
@ -72,6 +73,9 @@ begin
end;
FTimerData.Free;
if FDotsPatternBitmap <> 0 then
DeleteObject(FDotsPatternBitmap);
if FAppHandle <> 0 then
DestroyWindow(FAppHandle);
@ -556,6 +560,15 @@ begin
Assert(False, 'Trace:[TWin32WidgetSet.AssignSelf] Trying to code it. It''s probably wrong.');
end;
function TWin32WidgetSet.GetDotsPatternBitmap: HBitmap;
const
Dots: array[0..3] of Word = ($55, $AA, $55, $AA);
begin
if FDotsPatternBitmap = 0 then
FDotsPatternBitmap := CreateBitmap(4, 4, 1, 1, @Dots);
Result := FDotsPatternBitmap;
end;
{------------------------------------------------------------------------------
Method: TWin32WidgetSet.ShowHide
Params: Sender - The sending object