tvplanit: Support VpNavBar scaling with screen resolution.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6386 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/tvplanit/source/vpconst.pas

@@ -270,6 +270,8 @@ const
   { Hint support }
   MAX_HINT_WIDTH = 400;
 
+  DesignTimeDPI = 96;
+
 {$IFDEF LCL}
  {$IF LCL_FULLVERSION >= 1080100}
   VP_LCL_SCALING = 2;

components/tvplanit/source/vpcontactbuttons.pas

@@ -180,6 +180,9 @@ type
 
 implementation
 
+uses
+  VpConst;
+
 { TVpContactButtonBar }
 
 constructor TVpContactButtonBar.Create(AOwner: TComponent);

components/tvplanit/source/vpedshape.pas

@@ -121,7 +121,7 @@ implementation
 
 uses
   Math, TypInfo,
-  VpMisc, VpSr;
+  VpConst, VpMisc, VpSr;
 
 
 { TfrmEditShape }

components/tvplanit/source/vpjsonds.pas

@@ -66,7 +66,7 @@ implementation
 
 uses
   LazFileUtils,
-  jsonparser,
+  jsonscanner, jsonparser,
   VpSR, VpMisc;
 
 constructor TVpJSONDatastore.Create(AOwner: TComponent);
@@ -486,7 +486,7 @@ begin
   stream := TFileStream.Create(FFilename, fmOpenRead + fmShareDenyWrite);
   try
     Resources.ClearResources;
-    p := TJSONParser.Create(stream);
+    p := TJSONParser.Create(stream, [joUTF8]);
     try
       json := p.Parse as TJSONObject;
       resObjArray := json.Find('Resources', jtArray) as TJSONArray;

components/tvplanit/source/vpmisc.pas

@@ -59,8 +59,6 @@ const
 
   GranularityMinutes: Array[TVpGranularity] of Integer = (5, 6, 10, 15, 20, 30, 60);
 
-  DesignTimeDPI = 96;
-
 
 function DefaultEpoch : Integer;
   {-return the current century}

components/tvplanit/source/vpnavbar.pas

@@ -36,7 +36,7 @@ interface
 
 uses
   {$IFDEF LCL}
-  LMessages, LCLProc, LCLType, LCLIntf,
+  LMessages, LCLProc, LCLType, LCLIntf, LCLVersion,
   {$ELSE}
   Windows, Messages, MMSystem,
   {$ENDIF}
@@ -196,7 +196,7 @@ type
     FHotFolder: Integer;
     FImages: TImageList;
     FItemFont: TFont;
-    FItemSpacing: Word;
+    FItemSpacing: Integer;
     FPreviousFolder: Integer;
     FPreviousItem: Integer;
     FPlaySounds: Boolean;
@@ -248,6 +248,7 @@ type
     function GetFolder(Index: Integer): TVpNavFolder;
     function GetFolderCount: Integer;
     function GetContainer(Index: Integer): TVpFolderContainer;
+    function IsStoredItemSpacing: boolean;
     procedure SetActiveFolder(Value: Integer);
     procedure SetBackgroundColor(Value: TColor);
     procedure SetBackgroundImage(Value: TBitmap);
@@ -257,7 +258,7 @@ type
     procedure SetButtonHeight(Value: Integer);
     procedure SetImages(Value: TImageList);
     procedure SetItemFont(Value: TFont);
-    procedure SetItemSpacing(Value: Word);
+    procedure SetItemSpacing(Value: Integer);
     procedure SetSelectedItemFont(Value: TFont);
     procedure SetScrollDelta(Value: Integer);
 
@@ -299,6 +300,15 @@ type
     procedure WMEraseBkGnd(var Msg: TLMEraseBkGnd); message LM_ERASEBKGND;
     procedure WMNCHitTest(var Msg: TLMNCHitTest);  message LM_NCHITTEST;
     procedure WMSetCursor(var Msg: TLMSetCursor); message LM_SETCURSOR;
+    {$IF LCL_FullVersion >= 1080000}
+    procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+      const AXProportion, AYProportion: Double);
+    {$ENDIF}
+    {$IF VP_LCL_SCALING = 2}
+    procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double);
+    {$ELSEIF VP_LCL_SCALING = 1}
+    procedure ScaleFontsPPI(const AProportion: Double);
+    {$ENDIF}
     {$ENDIF}
     procedure CreateParams(var Params: TCreateParams); override;
     procedure CreateWnd; override;
@@ -331,12 +341,12 @@ type
     property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clWindow;
     property BackgroundImage: TBitmap read FBackgroundImage write SetBackgroundImage;
     property BackgroundMethod: TVpBackgroundMethod read FBackgroundMethod write SetBackgroundMethod;
-    property ButtonHeight: Integer read FButtonHeight write SetButtonHeight;
+    property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 0;
     property DrawingStyle: TVpFolderDrawingStyle read FDrawingStyle write SetDrawingStyle;
     property FolderCollection: TVpCollection read FFolders write FFolders;
     property Images: TImageList read FImages write SetImages;
     property ItemFont: TFont read FItemFont write SetItemFont;
-    property ItemSpacing: Word read FItemSpacing write SetItemSpacing;
+    property ItemSpacing: Integer read FItemSpacing write SetItemSpacing stored IsStoredItemSpacing;
     property PlaySounds: Boolean read FPlaySounds write FPlaySounds;
     property ScrollDelta: Integer read FScrollDelta write SetScrollDelta default 2;
     property SelectedItem: Integer read FSelectedItem write FSelectedItem;
@@ -375,6 +385,7 @@ type
     function GetFolderAt(X, Y: Integer): Integer;
     function GetItemAt(X, Y: Integer): Integer;
     function Container: TVpFolderContainer;
+    function GetRealButtonHeight: Integer;
     procedure InsertFolder(const ACaption: string; AFolderIndex: Integer);
     procedure AddFolder(const ACaption: string);
     procedure RemoveFolder(AFolderIndex: Integer);
@@ -473,6 +484,9 @@ uses
   Themes,
   VpNavBarPainter;
 
+const
+  DEFAULT_ITEMSPACING = 8;
+
 {$IFNDEF PAINTER}
 {DrawNavTab - returns the usable text area inside the tab rect.}
 function DrawNavTab(Canvas: TCanvas; const Client: TRect; BevelWidth: Integer;
@@ -981,8 +995,6 @@ end;
 {===== TVpNavBar ================================================}
 
 constructor TVpCustomNavBar.Create(AOwner: TComponent);
-{var
-  HSnd: THandle; }
 begin
   inherited Create(AOwner);
   BorderStyle := bsNone;
@@ -1006,7 +1018,11 @@ begin
   FItemFont.Name := Font.Name;
   FItemFont.OnChange := nabFontChanged;
   FItemFont.Color := clWindowText;
-  FItemSpacing := abs(FItemFont.Height) + 3;
+
+  FItemSpacing := DEFAULT_ITEMSPACING;
+  {$IF VP_LCL_SCALING = 0}
+  FItemSpacing := ScaleY(FItemSpacing, DesignTimeDPI)}
+  {$ENDIF}
 
   FSelectedItemFont := TFont.Create;
   FSelectedItemFont.Name := Font.Name;
@@ -1037,8 +1053,8 @@ begin
    {$ENDIF}
     NumGlyphs := 1;
     Left := -20;
-    Height := 15;
+    Height := ScaleY(15, DesignTimeDPI);
-    Width := 17;
+    Width := ScaleX(17, DesignTimeDPI);
   end;
 
   nabScrollDownBtn := TSpeedButton.Create(Self);
@@ -1053,8 +1069,8 @@ begin
    {$ENDIF}
     NumGlyphs := 1;
     Left := -20;
-    Height := 15;
+    Height := ScaleY(15, DesignTimeDPI);
-    Width := 17;
+    Width := ScaleX(17, DesignTimeDPI);
   end;
 
   {create edit control}
@@ -1064,8 +1080,8 @@ begin
     nabEdit.OnExit := nabCommitEdit;
   end;
 
-  Height := 240;
+  Height := ScaleY(240, DesignTimeDPI);
-  Width := 120;
+  Width := ScaleY(120, DesignTimeDPI);
   ParentColor := False;
 
   FAllowRearrange := True;
@@ -1073,7 +1089,7 @@ begin
   FBackgroundImage := TBitmap.Create;
   FBackgroundMethod := bmNormal;
 //  FBorderStyle := bsSingle;
-  FButtonHeight := 20;
+  FButtonHeight := 0;
   FActiveFolder := -1;
   FActiveItem := -1;
   FSelectedItem := -1;
@@ -1314,6 +1330,23 @@ begin
 end;
 {=====}
 
+function TVpCustomNavBar.GetRealButtonHeight: Integer;
+begin
+  if FButtonHeight = 0 then begin
+    if Font.IsDefault then
+      Canvas.Font.Assign(Screen.SystemFont)
+    else
+      Canvas.Font.Assign(Font);
+    Result := Canvas.TextHeight('Tg') + ScaleY(4, DesignTimeDPI) + 1;
+  end else
+    Result := ScaleY(FButtonHeight, DesignTimeDPI);
+end;
+
+function TVpCustomNavBar.IsStoredItemSpacing: Boolean;
+begin
+  Result := FItemSpacing <> DEFAULT_ITEMSPACING;
+end;
+
 function TVpCustomNavBar.Container: TVpFolderContainer;
 begin
   if Folders[FActiveFolder].FolderType = ftContainer then
@@ -1689,14 +1722,16 @@ end;
 function TVpCustomNavBar.nabGetFolderArea(Index: Integer): TRect;
 var
   I : Integer;
+  btnHeight: Integer;
 begin
   Unused(Index);
 
   Result := ClientRect;
+  btnHeight := GetRealButtonHeight;
   for I := 0 to ActiveFolder do
-    Inc(Result.Top, FButtonHeight);
+    Inc(Result.Top, btnHeight);
   for I := FolderCount-1 downto ActiveFolder+1 do
-    Dec(Result.Bottom, FButtonHeight);
+    Dec(Result.Bottom, btnHeight);
 end;
 {=====}
 
@@ -2733,6 +2768,7 @@ var
   R: TRect;
   R2: TRect;
   AllowChange: Boolean;
+  btnHeight: Integer;
 begin
   if Value <> FActiveFolder then begin
 
@@ -2740,6 +2776,7 @@ begin
       FActiveFolder := -1
     else
     if (Value > -1) and (Value < FolderCount) then begin
+       btnHeight := GetRealButtonHeight;
       { Fire DoFolderChange only if not dragging. }
       if nabDragFromItem = -1 then begin
         { Default for AllowChange is True. }
@@ -2774,14 +2811,14 @@ begin
           if Value > FActiveFolder then begin
             {up}
             YDelta := -FScrollDelta;
-            Inc(R.Bottom, Abs(Value-FActiveFolder)*FButtonHeight);
+            Inc(R.Bottom, Abs(Value-FActiveFolder)*btnHeight);
-            R2.Top := R2.Bottom+Abs(Value-FActiveFolder)*FButtonHeight;
+            R2.Top := R2.Bottom+Abs(Value-FActiveFolder)*btnHeight;
             R2.Bottom := R2.Top;
           end else begin
             {down}
             YDelta := +FScrollDelta;
-            Dec(R.Top, Abs(Value-FActiveFolder)*FButtonHeight);
+            Dec(R.Top, Abs(Value-FActiveFolder)*btnHeight);
-            R2.Bottom := R2.Top-Abs(Value-FActiveFolder)*FButtonHeight;
+            R2.Bottom := R2.Top-Abs(Value-FActiveFolder)*btnHeight;
             R2.Top := R2.Bottom;
           end;
           Y := RectHeight(R)-FScrollDelta;
@@ -2856,7 +2893,7 @@ begin
   if Value <> FButtonHeight then begin
     {Minimum ButtonHeight for CoolTabs is 17}
     if FDrawingStyle = dsCoolTab then begin
-      if Value < 17
+      if (Value < 17) and (FButtonHeight <> 0)
         then FButtonHeight := 17
         else FButtonHeight := Value;
     end else
@@ -2911,12 +2948,12 @@ begin
 end;
 {=====}
 
-procedure TVpCustomNavBar.SetItemSpacing(Value: Word);
+procedure TVpCustomNavBar.SetItemSpacing(Value: Integer);
 begin
-  if (Value > 0) then begin
+  if (FItemSpacing = Value) then
-    FItemSpacing := Value;
+    exit;
-    Invalidate;
+  FItemSpacing := Value;
-  end;
+  Invalidate;
 end;
 {=====}
 
@@ -3116,6 +3153,42 @@ begin
     end;
 end;
 
+{$IF LCL_FullVersion >= 1080000}
+procedure TVpCustomNavBar.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+  const AXProportion, AYProportion: Double);
+begin
+  inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
+  if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
+  begin
+    DisableAutoSizing;
+    try
+//      FButtonHeight := round(FButtonHeight * AYProportion);
+      if not IsStoredItemSpacing then
+        FItemSpacing := round(FItemSpacing * AYProportion);
+    finally
+      EnableAutoSizing;
+    end;
+  end;
+end;
+
+{$IF VP_LCL_SCALING = 2}
+procedure TVpCustomNavBar.ScaleFontsPPI(const AToPPI: Integer;
+  const AProportion: Double);
+begin
+  inherited;
+  DoScaleFontPPI(FItemFont, AToPPI, AProportion);
+  DoScaleFontPPI(FSelectedItemFont, AToPPI, AProportion);
+end;
+{$ELSEIF VP_LCL_SCALING = 1}
+procedure TVpCustomNavBar.ScaleFontsPPI(const AProportion: Double);
+begin
+  inherited;
+  DoScaleFontPPI(FItemFont.Font, AProportion);
+  DoScaleFontPPI(FScaledItem.Font, AProportion);
+end;
+{$ENDIF}
+{$ENDIF}
+
 initialization
   RegisterClass(TVpFolderContainer);
 

components/tvplanit/source/vpnavbarpainter.pas

@@ -37,6 +37,8 @@ type
     FSelectedItem: Integer;
     FSelectedItemFont: TFont;
     FShowButtons: Boolean;
+    FSmallImagesSize: Integer;
+    FLargeImagesSize: Integer;
 
     nabItemsRect: PRect;
     nabLastMouseOverItem: Integer;
@@ -49,12 +51,14 @@ type
 
     procedure DrawBackground(Canvas: TCanvas; R: TRect);
 
-    function DrawCoolTab(Canvas: TCanvas; R: TRect; ATabIndex: Integer;
+    function DrawCoolTab(Canvas: TCanvas; R: TRect;
-      ATabColor: TColor): TRect;
+      ATabIndex: Integer; ATabColor: TColor): TRect;
-    function DrawDefButton(Canvas: TCanvas; R: TRect; ATabIndex: Integer): TRect;
+    function DrawDefButton(Canvas: TCanvas; R: TRect;
-    function DrawEtchedButton(Canvas: TCanvas; R: TRect; ATabIndex: Integer): TRect;
+      ATabIndex: Integer): TRect;
-    function DrawStandardTab(Canvas: TCanvas; R: TRect; ATabIndex: Integer;
+    function DrawEtchedButton(Canvas: TCanvas; R: TRect;
-      ATabColor: TColor): TRect;
+      ATabIndex: Integer): TRect;
+    function DrawStandardTab(Canvas: TCanvas; R: TRect;
+      ATabIndex: Integer; ATabColor: TColor): TRect;
 
     procedure DrawItemHighlight(Canvas: TCanvas; R: TRect; Enable: Boolean);
     function DrawItemText(Canvas: TCanvas; AItem: TVpNavBtnItem; CurPos: Integer;
@@ -89,7 +93,7 @@ implementation
 
 uses
   Math, Themes,
-  VpMisc;
+  VpConst, VpMisc;
 
 type
   TVpNavBarOpener = class(TVpCustomNavBar);
@@ -104,7 +108,7 @@ begin
   FBackgroundColor := TVpNavBarOpener(FNavBar).BackgroundColor;
   FBackgroundImage := TVpNavBarOpener(FNavBar).BackgroundImage;
   FBackgroundMethod := TVpNavBarOpener(FNavBar).BackgroundMethod;
-  FButtonHeight := TVpNavBarOpener(FNavBar).ButtonHeight;
+  FButtonHeight := TVpNavBarOpener(FNavBar).GetRealButtonHeight;
   FClientWidth := TVpNavBarOpener(FNavBar).ClientWidth;
   FClientHeight := TVpNavBarOpener(FNavBar).ClientHeight;
   FDrawingStyle := TVpNavBarOpener(FNavBar).DrawingStyle;
@@ -131,6 +135,10 @@ end;
 
 { Draw the items for the active folder }
 procedure TVpNavBarPainter.DrawActiveFolderItems(Canvas: TCanvas; var CurPos: Integer);
+const
+  BUTTON_DISTANCE = 8;
+  LARGE_ICON_OFFSET = 4;
+  SMALL_ICON_OFFSET = 3;
 var
   folder: TVpNavFolder;
   item: TVpNavBtnItem;
@@ -138,15 +146,27 @@ var
   text: String;
   X: Integer;
   R: TRect;
+  largeIconOffs: Integer;
+  smallIconOffs: Integer;
 begin
   folder := FNavBar.Folders[FActiveFolder];
+  largeIconOffs := ScaleY(LARGE_ICON_OFFSET, DesignTimeDPI);
+  smallIconOffs := ScaleX(SMALL_ICON_OFFSET, DesignTimeDPI);
+
+  if FImages <> nil then begin
+    FLargeImagesSize := FImages.Width;
+    FSmallImagesSize := FImages.Width div 2;
+  end else begin
+    FLargeImagesSize := 32;
+    FSmallImagesSize := 16;
+  end;
 
   if folder.FolderType = ftDefault then begin
     if folder.ItemCount = 0 then
       exit;
 
     // Distance of top-most icon to the last upper button
-    Inc(CurPos, 8);
+    Inc(CurPos, ScaleY(BUTTON_DISTANCE, DesignTimeDPI));
 
     with nabItemsRect^ do begin
       Top := CurPos;
@@ -181,7 +201,7 @@ begin
 
         {make the icon's bottom blend into the label's top}
         R := item.IconRect;
-        inc(R.Bottom, 4);
+        inc(R.Bottom, largeIconOffs);
         item.IconRect := R;
         CurPos := item.IconRect.Bottom;
 
@@ -197,7 +217,7 @@ begin
 
         {make the icon's right blend into the label's left}
         R := item.IconRect;
-        inc(R.Right, 3);
+        inc(R.Right, smallIconOffs);
         item.IconRect := R;
 
         {now, draw the text}
@@ -329,15 +349,15 @@ begin
     Points[2] := Point(R.Left + 14, R.Top + 6);  {Control point}
     Points[3] := Point(R.Left + 15, R.Top + 1);  {Control point}
     Points[4] := Point(R.Left + 21, R.Top + 0);  {End point}
-    {$IFNDEF VERSION4}
+   {$IFNDEF VERSION4}
     {$IFDEF CBuilder}
     PolyBezier(Points);
     {$ELSE}
     Polyline(Points);
     {$ENDIF}
-   {$ELSE}
+  {$ELSE}
     PolyBezier([Points[1], Points[2], Points[3], Points[4]]);
-   {$ENDIF}
+  {$ENDIF}
 
     {Draw the top of the tab}
     MoveTo(R.Left + 21,  R.Top);
@@ -503,25 +523,30 @@ end;
 
 function TVpNavBarPainter.DrawItemText(Canvas: TCanvas; AItem: TVpNavBtnItem;
   CurPos: Integer; AText: String; AtLargeIcon: Boolean; out AWidth: Integer): Boolean;
+const
+  HOR_MARGIN = 5;
 var
   R: TRect;
   s: String;
   txtWidth: Integer;
   bkMode: Integer;
+  horDist: Integer;
 begin
   Result := false;
 
   if AtLargeIcon then
   begin
+    horDist := ScaleX(HOR_MARGIN, DesignTimeDPI);
+
     R.Top := CurPos;
-    R.Bottom := CurPos + FButtonHeight div 2 - 7;
+    R.Bottom := CurPos + FButtonHeight div 2 - 7;   // what is -7 good for?
     R.Left := 0;
     R.Right := FNavBar.ClientWidth - 1;
     AItem.LabelRect := R;
     AItem.DisplayName := GetLargeIconDisplayName(Canvas, R, AText);
     AWidth := Canvas.TextWidth(AItem.DisplayName);
-    R.Left := Max(5, (FNavBar.ClientWidth - AWidth) div 2);
+    R.Left := Max(horDist, (FNavBar.ClientWidth - AWidth) div 2);
-    R.Right := Min(R.Left + AWidth, FNavBar.ClientWidth - 5);
+    R.Right := Min(R.Left + AWidth, FNavBar.ClientWidth - hordist);
     AItem.LabelRect := R;
     if R.Top > nabItemsRect^.Bottom then
       Exit;
@@ -542,7 +567,7 @@ begin
     R.Top := CurPos;
     R.Bottom := CurPos + FButtonHeight div 2 - 7;
     R.Left := AItem.IconRect.Right;
-    R.Right := R.Left + FNavBar.ClientWidth - R.Left - 7;
+    R.Right := R.Left + FNavBar.ClientWidth - R.Left - ScaleX(7, DesignTimeDPI);
     AItem.LabelRect := R;
     if R.Top > nabItemsRect^.Bottom then
       Exit;
@@ -564,23 +589,28 @@ begin
   Result := true;
 end;
 
-{ Draw a large icon: centered horizontally, text to be drawn underneath icon. }
+{ Draw a large icon: centered horizontally, text to be drawn underneath icon.
+  CurPos is upper edge of the icon. }
 function TVpNavBarPainter.DrawLargeIcon(Canvas: TCanvas; AItem: TVpNavBtnItem;
   CurPos: Integer): Boolean;
+const
+  MARGIN = 2;
 var
   W, H: Integer;
   R: TRect;
+  dist: Integer;
 begin
   Result := false;
 
   { If an image list is assigned then use the image size.
     If no image list is assinged then assume a 32 x 32 image size. }
+  dist := ScaleX(MARGIN, DesignTimeDPI);
   if Assigned(FImages) then begin
-    W := FImages.Width + 2;
+    W := FImages.Width + 2*dist;
-    H := FImages.Height + 2;
+    H := FImages.Height + 2*dist;
   end else begin
-    W := 32;
+    W := ScaleX(32, DesignTimeDPI);
-    H := 32;
+    H := ScaleY(32, DesignTimeDPI);
   end;
 
   R.Top := CurPos;
@@ -595,7 +625,7 @@ begin
   if FShowButtons then begin
     DrawItemHighlight(Canvas, R, FActiveItem = AItem.Index);
     if Assigned(FImages) and (AItem.IconIndex >= 0) and (AItem.IconIndex < FImages.Count) then
-      FImages.Draw(Canvas, R.Left + 2, R.Top + 2, AItem.IconIndex);
+      FImages.Draw(Canvas, R.Left + dist, R.Top + dist, AItem.IconIndex);
   end;
 
   Result := true;
@@ -605,23 +635,24 @@ end;
 function TVpNavBarPainter.DrawSmallIcon(Canvas: TCanvas; AItem: TVpNavBtnItem;
   CurPos: Integer): Boolean;
 const
-  W = 16;
+  DELTA = 8;
-  H = 16;
 var
   lOffset: Integer;
   bmp: TBitmap;
   R: TRect;
+  del: Integer;
 begin
   Result := false;
 
   {glyph is at the left}
   R.Top := CurPos;
+  del := ScaleY(DELTA, DesignTimeDPI);
   lOffset := abs(Canvas.Font.Height) div 2;
-  if lOffset > 8 then
+  if lOffset > del then
-    R.Top := R.Top + lOffset - 8;
+    R.Top := R.Top + lOffset - del;
-  R.Bottom := R.Top + H;
+  R.Bottom := R.Top + FSmallImagesSize;
-  R.Left := 8;
+  R.Left := del;
-  R.Right := R.Left + W;
+  R.Right := R.Left + FSmallImagesSize;
   AItem.IconRect := R;
   if R.Top > nabItemsRect^.Bottom then
     Exit;  // Returns false
@@ -647,9 +678,21 @@ end;
   Returns the usable text area inside the tab rect.}
 function TVpNavBarPainter.DrawStandardTab(Canvas: TCanvas; R: TRect;
   ATabIndex: Integer; ATabColor: TColor): TRect;
+const
+  _LEFT_DISTANCE = 10;
+  _RIGHT_DISTANCE = 2;
+  _RADIUS = 2;
+var
+  leftDist: Integer;
+  rightDist: Integer;
+  radius: Integer;
 begin
   Result := R;
 
+  leftDist := ScaleX(_LEFT_DISTANCE, DesignTimeDPI);
+  rightDist := ScaleX(_RIGHT_DISTANCE, DesignTimeDPI);
+  radius := ScaleX(_RADIUS, DesignTimeDPI);
+
   {fill the tab area}
   Canvas.Brush.Style := bsSolid;
   Canvas.Brush.Color := clBtnFace;
@@ -673,16 +716,25 @@ begin
   Canvas.Brush.Style := bsSolid;
   Canvas.Pen.Color := ATabColor;
   Canvas.Polygon([
+    Point(R.Left + leftDist,            R.Bottom - 1),                 // 10  -1
+    Point(R.Left + leftDist,            R.Top + radius + 1),           // 10   3
+    Point(R.Left + leftDist + radius,   R.Top + 1),                    // 12   1
+    Point(R.Right - rightDist - radius, R.Top + 1),                    // -4   1
+    Point(R.Right - rightDist,          R.Top + radius + 1),           // -2   3
+    Point(R.Right - rightDist,          R.Bottom - 1)                  // -2  -1
+  ]);
+  {
     Point(R.Left + 10, R.Bottom - 1),
     Point(R.Left + 10, R.Top + 3),
     Point(R.Left + 12, R.Top + 1),
     Point(R.Right - 4, R.Top + 1),
     Point(R.Right - 2, R.Top + 3),
     Point(R.Right - 2, R.Bottom - 1)
-  ]);
+  ]); }
 
   {highlight tab}
   Canvas.Pen.Color := clBtnHighlight;
+  {
   Canvas.PolyLine([
     Point(R.Left, R.Bottom - 2),
     Point(R.Left + 8, R.Bottom - 2),
@@ -690,13 +742,23 @@ begin
     Point(R.Left + 9, R.Top + 3),
     Point(R.Left + 11, R.Top + 1),
     Point(R.Right - 1, R.Top + 1)
+  ]);}
+  Canvas.PolyLine([
+    Point(R.Left,                     R.Bottom - radius),             //  0   -2
+    Point(R.Left + leftDist - radius, R.Bottom - radius),             //  8   -2
+    Point(R.Left + leftdist - 1,      R.Bottom - radius - 1),         //  9   -3
+    Point(R.Left + leftDist - 1,      R.Top + radius + 1),            //  9    3
+    Point(R.Left + leftDist + 1,      R.Top + 1),                     // 11    1
+    Point(R.Right - 1,                R.Top + 1)                      // -1    1
   ]);
 
+
   {draw border}
   Canvas.Pen.Color := clBlack;
+  {
   Canvas.PolyLine([
-    Point(R.Left, R.Bottom - 1),
+    Point(R.Left,      R.Bottom - 1),
-    Point(R.Left + 9, R.Bottom - 1),
+    Point(R.Left + 9,  R.Bottom - 1),
     Point(R.Left + 10, R.Bottom - 2),
     Point(R.Left + 10, R.Top + 4),
     Point(R.Left + 11, R.Top + 3),
@@ -704,6 +766,17 @@ begin
     Point(R.Right - 2, R.Top + 2),
     Point(R.Right - 1, R.Top + 3),
     Point(R.Right - 1, R.Bottom - 1)
+  ]);}
+  Canvas.PolyLine([
+    Point(R.Left,                R.Bottom - 1),                     //  0    -1
+    Point(R.Left + leftDist - 1, R.Bottom - 1),                     //  9    -1
+    Point(R.Left + leftDist,     R.Bottom - radius),                // 10    -2
+    Point(R.Left + leftdist,     R.Top + radius + 2),               // 10    +4
+    Point(R.Left + leftdist + 1, R.Top + radius + 1),               // 11    +3
+    Point(R.Left + leftdist + 2, R.Top + radius),                   // 12    +2
+    Point(R.Right - radius,      R.Top + radius),                   // -2    +2
+    Point(R.Right - radius + 1,  R.Top + radius + 1),               // -1    +3
+    Point(R.Right -1,            R.Bottom - 1)                      // -1    -1
   ]);
 
   Result := Rect(R.Left + 1, R.Top + 2, R.Right - 2, R.Bottom);
@@ -873,9 +946,9 @@ begin
     else
       TR := FNavBar.ClientRect;
 
-    { Draw background }
     DrawBackground(DrawBmp.Canvas, TR);
 
+    { Draw background }
     if FNavBar.FolderCount = 0 then begin
       nabScrollUpBtn.Visible := False;
       nabScrollDownBtn.Visible := False;
@@ -895,7 +968,7 @@ begin
 
     { Copy the buffer bitmap to the control }
     FNavBar.Canvas.CopyMode := cmSrcCopy;
-    FNavBar.Canvas.CopyRect(MyRect, DrawBmp.Canvas, Rect(0, 0, DrawBmp.Width,DrawBmp.Height));
+    FNavBar.Canvas.CopyRect(MyRect, DrawBmp.Canvas, Rect(0, 0, DrawBmp.Width, DrawBmp.Height));
 
     { Show/hide scroll buttons }
     ProcessScrollButtons;
@@ -906,24 +979,34 @@ begin
 end;
 
 procedure TVpNavBarPainter.ProcessScrollButtons;
+const
+  DISTANCE = 5;
+var
+  dist: Integer;
+  w, h: Integer;
 begin
   if not (csDesigning in FNavBar.ComponentState) then begin
+    dist := ScaleY(DISTANCE, DesignTimeDPI);
+
     {show the top scroll button}
     if TVpNavBarOpener(FNavBar).nabShowScrollUp() then begin
-      nabScrollUpBtn.Top := FNavBar.Folders[FActiveFolder].Rect.Bottom + 5;
+      w := nabScrollUpBtn.Width;
-      nabScrollUpBtn.Left := FNavBar.ClientWidth - 20;
+      nabScrollUpBtn.Top := FNavBar.Folders[FActiveFolder].Rect.Bottom + dist;
+      nabScrollUpBtn.Left := FNavBar.ClientWidth - w - dist;
       nabScrollUpBtn.Visible := True;
     end else
       nabScrollUpBtn.Visible := False;
 
     {show the bottom scroll button}
     if TVpNavBarOpener(FnavBar).nabShowScrollDown() then begin
+      w := nabScrollDownBtn.Width;
+      h := nabScrollDownBtn.Height;
       if FActiveFolder = FNavBar.FolderCount-1 then
         {there are no folders beyond the active one}
-        nabScrollDownBtn.Top := FNavBar.ClientHeight -20
+        nabScrollDownBtn.Top := FNavBar.ClientHeight - h - dist
       else
-        nabScrollDownBtn.Top := FNavBar.Folders[FActiveFolder+1].Rect.Top - 20;
+        nabScrollDownBtn.Top := FNavBar.Folders[FActiveFolder+1].Rect.Top - h - dist;
-      nabScrollDownBtn.Left := FNavBar.ClientWidth - 20;
+      nabScrollDownBtn.Left := FNavBar.ClientWidth - w - dist;
       nabScrollDownBtn.Visible := True;
     end else
       nabScrollDownBtn.Visible := False;

components/tvplanit/source/vpprtprvdlg.pas

@@ -163,7 +163,7 @@ implementation
 {$ENDIF}
 
 uses
-  VpPrtFmt;
+  VpConst, VpPrtFmt;
 
 { TfrmPrintPreview }