File: zoneheader.inc

package info (click to toggle)
lazarus 2.0.0%2Bdfsg-2
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 214,460 kB
  • sloc: pascal: 1,862,622; xml: 265,709; cpp: 56,595; sh: 3,008; java: 609; makefile: 535; perl: 297; sql: 222; ansic: 137
file content (442 lines) | stat: -rw-r--r-- 13,919 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
type
  TDockHeaderImageKind =
  (
    dhiRestore,
    dhiClose
  );

  TDockHeaderImages = array[TDockHeaderImageKind] of TCustomBitmap;

const
  DockHeaderImageNames: array[TDockHeaderImageKind] of String =
  (
{ dhiRestore } 'easy_dock_restore',
{ dhiClose   } 'easy_dock_close'
  );

var
  DockBtnImages: TDockHeaderImages;


procedure CreateDockHeaderImages;
var
  ImageKind: TDockHeaderImageKind;
begin
  for ImageKind := Low(TDockHeaderImageKind) to High(TDockHeaderImageKind) do
    DockBtnImages[ImageKind] := CreateBitmapFromResourceName(HInstance, DockHeaderImageNames[ImageKind]);
end;

procedure DestroyDockHeaderImages;
var 
  ImageKind: TDockHeaderImageKind;
begin
{$IFDEF freeImages}
  //called from unit finalization only!
  // this code can result in crashes, due to missing handles!
  for ImageKind := Low(TDockHeaderImageKind) to High(TDockHeaderImageKind) do
    FreeAndNil(DockBtnImages[ImageKind]);
{$ELSE}
{$ENDIF}
end;


{ TEasyDockHeader }

type
  TZonePartMap = record
    dTop, dBottom, dLeft, dRight: integer;
  end;

const //zone decoration sizes
  dSizer = 4;
  dBorder = 2; //frame and inner bevel
  dDist = 1; //button distance
  dButton = 14; //include some space for themes
  dHeader = dButton + 2*dBorder; // 22 - dSizer; //splitter outside header!
//minimal (Delphi) header
  GrabberSize = 10; // 12;
  dDDist = 1;
  dDBorder = 1;
  dDHeader = GrabberSize; //?
  dDButton = GrabberSize - 2*dDBorder; //10?

(* Zone part map.
  In portrait mode (header on top), the zone rectangle is adjusted according
  to the given offsets. In landscape mode (header on the left), the offsets
  have to be applied to the rotated coordinates.

  Positive offsets mean self-relative adjustment, towards the opposite edge.
  This operation has highest precedence.
  Negative offsets mean adjustment relative to the adjusted opposite edge.

  zpAll excludes the splitter and client area.
  zpCaption excludes borders and buttons from zpAll.
*)
(*
  The splitter is excluded first, if present.
  [zpSizer] entry is unused.
*)
HeaderPartMap: array[TEasyHeaderStyle, TEasyZonePart] of TZonePartMap = (
//hsMinimal
  (
    {zpNowhere} (),
    {zpClient}  (dTop:dDHeader; dBottom:0),
    {zpAll}     (dTop:0; dBottom:-dDHeader),
    {zpCaption} (dTop:dDBorder; dBottom:-dDButton; dLeft:dDBorder; dRight:2*dDBorder+dDButton),
    {zpSizer}   (dTop:0; dBottom:-dSizer),
  {$IFDEF restore}
    {zpRestoreButton} (),
  {$ENDIF}
    {zpCloseButton} (dTop:dDBorder; dBottom:-dDButton; dLeft:-dDButton; dRight:dDBorder)
  ),
//hsForm
  (
    (),    //zpNowhere - not in any zone
    (dTop:dHeader; dBottom:0),    //zpClient - on client control
    (dTop:0; dBottom:-dHeader),    //zpAll - total header rect
    (dTop:dBorder; dBottom:-dButton; dLeft:dBorder; dRight:dBorder+dButton),    //zpCaption
    (dTop:0; dBottom:-dSizer),    //zpSizer - splitter/sizer
    {$IFDEF restore}
    (dTop:dBorder; dBottom:-dButton; dLeft:-dButton; dRight:dButton+2*dBorder)    //zpRestoreButton,  // header restore button
    {$ENDIF}
    (dTop:dBorder; dBottom:-dButton; dLeft:-dButton; dRight:dBorder)    //zpCloseButton     // header close button
  ),
 //hsNone deserves special handling, the map is ignored
  (
    {zpNowhere} (),
    {zpClient}  (dTop:0; dBottom:0),
    {zpAll}     (dTop:0; dBottom:-dDHeader),
    {zpCaption} (dTop:dDBorder; dBottom:-dDButton; dLeft:dDBorder; dRight:2*dDBorder+dDButton),
    {zpSizer}   (dTop:0; dBottom:-dSizer),
  {$IFDEF restore}
    {zpRestoreButton} (),
  {$ENDIF}
    {zpCloseButton} (dTop:dDBorder; dBottom:-dDButton; dLeft:-dDButton; dRight:dDBorder)
  )
);

constructor TEasyDockHeader.Create;
{
  procedure dump;
  var
    r, r2: TRect;
  const
    hc = true;
    orn = doVertical;
  begin
    r := Rect(0, 0, 200, 200); //LTBR
    r2 := GetRectOfPart(r, orn, zpAll, hc);
    DebugLn('%s (%d,%d)-(%d,%d)', ['header ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
    r2 := GetRectOfPart(r, orn, zpCaption, hc);
    DebugLn('%s (%d,%d)-(%d,%d)', ['caption', r2.Top, r2.Left, r2.Bottom, r2.Right]);
    r2 := GetRectOfPart(r, orn, zpCloseButton, hc);
    DebugLn('%s (%d,%d)-(%d,%d)', ['closer ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
    r2 := GetRectOfPart(r, orn, zpClient, hc);
    DebugLn('%s (%d,%d)-(%d,%d)', ['client ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
    r2 := GetRectOfPart(r, orn, zpSizer, hc);
    DebugLn('%s (%d,%d)-(%d,%d)', ['sizer  ', r2.Top, r2.Left, r2.Bottom, r2.Right]);
  end;
}
begin
  //HeaderSize := dHeader; //some meaningful value?
//debug
  //dump; - not shown in console
end;

function TEasyDockHeader.GetRectOfPart(ARect: TRect; AOrientation: TDockOrientation;
  APart: TEasyZonePart; HasSplitter: boolean; AStyle: TEasyHeaderStyle): TRect;
begin
(* ARect is (must be) TLBR zone rectangle, on input.
  HasSplitter determines whether to exclude the splitter from ARect,
  and also the splitter area itself.

  hsNone (no header) must be handled separately.
*)
  if (APart = zpNowhere)
  or ((APart = zpSizer) and not HasSplitter)
  or ((AStyle = hsNone) and (APart <> zpClient))
  then begin
    Result := Rect(0,0,0,0);
    exit;
  end;

  Result := ARect;
  if AStyle = hsNone then
    exit; //client fills entire area

  with HeaderPartMap[AStyle, APart] do begin
    if AOrientation = doVertical then begin //portrait
    //handle client w/o splitter
      if (APart = zpSizer) then begin
        Result.Bottom := Result.Top + dSizer;
        exit;
      end;
      if HasSplitter then
        inc(Result.Top, dSizer); //exclude splitter(?)
      if dTop > 0 then
        inc(Result.Top, dTop);
      if dBottom > 0 then
        dec(Result.Bottom, dBottom)
      else if dBottom < 0 then
        Result.Bottom := Result.Top - dBottom;
      if dTop < 0 then
        Result.Top := Result.Bottom + dTop;
      if dLeft > 0 then
        inc(Result.Left, dLeft);
      if dRight > 0 then
        dec(Result.Right, dRight)
      else if dRight < 0 then
        Result.Right := Result.Left + dRight;
      if dLeft < 0 then
        Result.Left := Result.Right + dLeft;
    end else begin //landscape
    //handle client w/o splitter
      if (APart = zpSizer) then begin
        Result.Right := Result.Left + dSizer;
        exit;
      end;
      if HasSplitter then
        inc(Result.Left, dSizer);
      if dTop > 0 then
        inc(Result.Left, dTop);
      if dBottom > 0 then
        dec(Result.Right, dBottom)
      else if dBottom < 0 then
        Result.Right := Result.Left - dBottom;
      if dTop < 0 then
        Result.Left := Result.Right + dTop;

      if dLeft > 0 then
        dec(Result.Bottom, dLeft);
      if dRight > 0 then
        inc(Result.Top, dRight)
      else if dRight < 0 then
        Result.Top := Result.Bottom + dRight;
      if dLeft < 0 then
        Result.Bottom := Result.Top - dLeft;
    end;
  end;
end;

function TEasyDockHeader.FindPart(AZone: TEasyZone; MousePos: TPoint; fButtonDown: boolean): TEasyZonePart;
var
  SubRect, r: TRect;
  Control: TControl;
  Part: TEasyZonePart;
  aHandle : HWND;
  aOrient: TDockOrientation;

  function MouseInPart(APart: TEasyZonePart): boolean;
  begin
  //on hit: retain Part and SubRect
    SubRect := GetRectOfPart(r, aOrient, APart, AZone.HasSizer, AZone.Style);
    Result := PtInRect(SubRect, MousePos);
    if Result then
      Part := APart;
  end;

begin
(* Called from mouse message handler (only!).
  Remember draw state of current zone.
*)
//exclude higher level splitters?
  r := AZone.GetBounds;
  if not PtInRect(r, MousePos) or (AZone.Parent = nil) then
  //possibly empty root zone
    Part := zpNowhere
  else if (AZone.FChildControl = nil) then begin
  //newSplitter: also zones without controls can have an splitter
    Control := nil;
    aOrient := AZone.Parent.Orientation;
    if not AZone.HasSizer or not MouseInPart(zpSizer) then
      Part := zpNowhere; //client?
  end else begin
    Control := AZone.FChildControl;
    aOrient := Control.DockOrientation;
    if MouseInPart(zpSizer) or MouseInPart(zpCloseButton)
    {$IFDEF restore}
      or MouseInPart(zpRestoreButton)
    {$ENDIF}
    or MouseInPart(zpClient)
    then
      //all done, result stored in Part
    else
      Part := zpCaption; //include borders
  end;
{ TODO -cdocking : sometimes Part is invalid? }
//DebugLn('IN ', PartNames[Part]);

  aHandle:=AZone.GetHandle;
//check old state changed - buttons also change state on mouse enter/exit
  if (self.MouseZone <> nil) //else Mouse... invalid
  and ((MouseZone <> AZone) or (MousePart in HeaderButtons)) then
      InvalidateRect(aHandle, @PartRect, false); //old button
//check new state
  if (Part in HeaderButtons) then begin
    InvalidateRect(aHandle, @SubRect, false); //refresh button
  end;
//set new state
  MouseZone := AZone;
  MousePart := Part;
  MouseDown := fButtonDown;
  PartRect := SubRect;
//done
  Result := Part;
end;

procedure TEasyDockHeader.Draw(AZone: TEasyZone; ACanvas: TCanvas; ACaption: string; const MousePos: TPoint);
(* Problem with colors on other than win32 widgetsets (gtk2...)
*)
const
  clBack = clHighlight;
  clFont = clHighlightText;

var
  IsMouseDown: Boolean;

  //procedure DrawButton(ARect: TRect; IsMouseDown, IsMouseOver: Boolean; ABitmap: TCustomBitmap); inline;
  procedure DrawButton(ARect: TRect; ABitmap: TCustomBitmap);
  const
    // ------------- Pressed, Hot -----------------------
    BtnDetail: array[Boolean, Boolean] of TThemedToolBar =
    (
     (ttbButtonNormal, ttbButtonHot),
     (ttbButtonNormal, ttbButtonPressed)
    );
  var
    Details: TThemedElementDetails;
    dx, dy: integer;
    IsMouseOver: boolean;
  begin
    ACanvas.FillRect(ARect);
    IsMouseOver := PtInRect(ARect, MousePos);
    Details := ThemeServices.GetElementDetails(BtnDetail[IsMouseDown, IsMouseOver]);
    ThemeServices.DrawElement(ACanvas.Handle, Details, ARect);
    ARect := ThemeServices.ContentRect(ACanvas.Handle, Details, ARect);
  //move button into rect, excluding border
    dx := (ARect.Right - ARect.Left - ABitmap.Width) div 2;
    dy := (ARect.Bottom - ARect.Top - ABitmap.Height) div 2;
    ACanvas.Draw(ARect.Left + dx, ARect.Top + dy, ABitmap);
  end;

  procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer);
  begin
    with ACanvas do
    begin
      Pen.Color := clBtnHighlight;
      MoveTo(Right, Top);
      LineTo(Left, Top);
      LineTo(Left, Bottom);
      Pen.Color := clBtnShadow;
      LineTo(Right, Bottom);
      LineTo(Right, Top);
    end;
  end;

var
  BtnRect: TRect;
  ARect, DrawRect: TRect;
  // LCL doesn't handle orientation in TFont
  OldFont, RotatedFont: HFONT;
  OldMode: Integer;
  ALogFont: TLogFont;
  AOrientation: TDockOrientation;
  AControl: TControl;
  AStyle: TEasyHeaderStyle;
  HasSizer: boolean;
begin
(* Some colors inavailable on some widgetsets!
*)
  if AZone.Style = hsNone then
    exit; //no header at all

  IsMouseDown := (GetKeyState(VK_LBUTTON) and $80) <> 0;
//debug
  AControl := AZone.FChildControl;
  AStyle := AZone.Style;
  HasSizer := AZone.HasSizer;
  AOrientation := AControl.DockOrientation;

  ARect := AZone.GetBounds;
  ACanvas.Brush.Color := clBtnFace;

//draw splitter?
  if HasSizer then begin
  // border?
    BtnRect := GetRectOfPart(ARect, AOrientation, zpSizer, HasSizer, AStyle);
    ACanvas.FillRect(BtnRect);
  end;

//erase - which color(s)?
  DrawRect := GetRectOfPart(ARect, AOrientation, zpAll, HasSizer, AStyle);
  //ACanvas.Brush.Color := clBack; // clActiveCaption;
  ACanvas.FillRect(DrawRect);

//border
  InflateRect(DrawRect, -1, -1); //outer bevel?
  ACanvas.Brush.Color := clBtnShadow;
  ACanvas.FrameRect(DrawRect); //1 pixel border
  ACanvas.Brush.Color := clBtnFace;

// draw caption
  case AStyle of
  hsMinimal:
    with DrawRect do begin
      DrawRect := GetRectOfPart(ARect, AOrientation, zpCaption, HasSizer, AStyle);
      if AOrientation = doVertical then begin
        inc(Top, dDBorder);
        DrawGrabberLine(Left, Top, Right, Top+2);
        inc(Top, 3);
        DrawGrabberLine(Left, Top, Right, Top+2);
      end else begin
        inc(Left, dDBorder);
        DrawGrabberLine(Left, Top, Left+2, Bottom);
        inc(Left, 3);
        DrawGrabberLine(Left, Top, Left+2, Bottom);
      end;
    end;
  hsForm:
    begin
      //ACanvas.Font.Color := clFont; //clCaptionText;
      DrawRect := GetRectOfPart(ARect, AOrientation, zpCaption, HasSizer, AStyle);

      OldMode := SetBkMode(ACanvas.Handle, TRANSPARENT);

    //for some reason the caption is not offset properly?
      if AOrientation = doVertical then begin
        inc(DrawRect.Left, dBorder); //looks better
        DrawText(ACanvas.Handle, PChar(ACaption), -1, DrawRect, DT_LEFT or DT_SINGLELINE or DT_VCENTER)
      end else begin
        OldFont := 0;
        if GetObject(ACanvas.Font.Reference.Handle, SizeOf(ALogFont), @ALogFont) <> 0 then
        begin
          ALogFont.lfEscapement := 900;
          RotatedFont := CreateFontIndirect(ALogFont);
          if RotatedFont <> 0 then
            OldFont := SelectObject(ACanvas.Handle, RotatedFont);
        end;
        // from msdn: DrawText doesnot support font with orientation and escapement <> 0
        //TextOut(ACanvas.Handle, DrawRect.Left, DrawRect.Bottom, PChar(ACaption), Length(ACaption));
        TextOut(ACanvas.Handle, DrawRect.Left-2, DrawRect.Bottom-2, PChar(ACaption), Length(ACaption));
        if OldFont <> 0 then
          DeleteObject(SelectObject(ACanvas.Handle, OldFont));
      end;
      SetBkMode(ACanvas.Handle, OldMode);
    end;
  end;

// buttons - which colors to use?
  ACanvas.Brush.Color := clBtnFace;
  //ACanvas.Pen.Color := clButtonText;

// draw close button
  BtnRect := GetRectOfPart(ARect, AOrientation, zpCloseButton, HasSizer, AStyle);
  DrawButton(BtnRect, DockBtnImages[dhiClose]);

{$IFDEF restore}
// draw restore button
  BtnRect := GetRectOfPart(ARect, AOrientation, zpRestoreButton, HasSizer, AStyle);
  DrawButton(BtnRect, DockBtnImages[dhiRestore]);
{$ENDIF}
end;