Display extra text in treeview nodes, not just node.text - delphi

I have a TTreeView in Delphi, with nodes at three levels.
I use node data to store another label besides the node text.
Type
TNodeData = class
ExtraNodeLabel: WideString;
//... other members
end;
I have an OnAdvancedCustomDrawItem event, where i want to display this ExtraNodeLabel before the node text.
I wish to achieve this:
The blue text would be the extra label.
higlighted item: first two words are also an extra label
What i got so far, is this:
Problems:
For some reason i can't draw text with different style if i use DrawText/drawTextW (I need drawtextW because of unicode data)
The other problem is, that anything outside the dotted focus rectangle is unclickable
What needs to be solved:
How can i draw text with different style using DrawText/DrawtextW
How can i make the whole text clickable?
Code:
procedure TMainForm.TntTreeView1AdvancedCustomDrawItem(
Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState;
Stage: TCustomDrawStage; var PaintImages, DefaultDraw: Boolean);
var
txtrect, fullrect : TRect;
DC: HDC;
fs: integer;
fc: TColor;
ExtralabelRect: TRect;
nData: TNodeData;
begin
nData := nil;
if assigned(Node.Data) then begin
nData := TNodeData(Node.Data);
end;
DC := TntTreeView1.canvas.Handle;
txtRect := Node.DisplayRect(True);
fullrect := Node.DisplayRect(False);
if stage = cdPostPaint then begin
TntTreeView1.Canvas.FillRect(txtRect);
if (cdsFocused In State) And (cdsSelected in State) then begin
DrawFocusRect(DC,txtRect);
end;
txtRect.Left := txtRect.Left + 1;
txtRect.Top := txtRect.Top + 1;
txtRect.Right := txtRect.Right - 1;
txtRect.Bottom := txtRect.Bottom - 1;
ExtralabelRect := txtRect;
fs := TntTreeView1.Canvas.Font.size;
fc := TntTreeView1.Canvas.Font.Color;
if (nData <> nil) And (nData.ExtraNodeLabel <> '') then begin
TntTreeView1.Canvas.Font.Size := 7;
TntTreeView1.Canvas.Font.color := clBlue;
DrawTextW(
DC,
PWideChar(nData.ExtraNodeLabel),
Length(nData.ExtraNodeLabel),
ExtraLabelRect,
DT_LEFT or DT_CALCRECT or DT_VCENTER
);
DrawTextW(
DC,
PWideChar(nData.ExtraNodeLabel),
Length(nData.ExtraNodeLabel),
ExtraLabelRect,
DT_LEFT or DT_VCENTER
);
txtRect.right := txtRect.Right + ExtraLabelRect.Right + 5;
txtRect.Left := ExtraLabelRect.Right + 5;
end;
TntTreeView1.Canvas.Font.Size := fs;
TntTreeView1.Canvas.Font.color := fc;
DrawTextW(
DC,
PWideChar((Node as TTntTreeNode).Text),
-1,
txtRect,
DT_LEFT or DT_VCENTER
);
end;
end;

Solution by the OP
I managed to partially solve custom drawing, by defining a TFont variable, and using SelectObject and setTextColor. Setting font color and style works, but setting the font size doesn't.
var
nFont: TFont;
begin
DC := TntTreeView1.Canvas.Handle;
NFont := TFont.Create;
// rest of the code here ...
// i tried to set nFont.Size, but it doesn't seem to work
nFont.Size := 7;
nFont.Color := colorToRGB(clBlue);
nFont.Style := TntTreeview1.Font.Style + [fsBold];
SelectObject(DC,NFont.Handle);
SetTextColor(DC,colortoRGB(clBlue));
DrawTextW(
DC,
PWideChar(nData.nodeLabel),
Length(nData.nodeLabel),
ExtraLabelRect,
DT_LEFT or DT_VCENTER
);
// rest of the code here
end;
Source:
I used the idea from here
Update 2
I solved the second problem by setting the treeview's RowSelect property to true.
For this, to work, i had to set the ShowLines property to false, and custom draw the lines and the buttons. It works now.
Update 3
I improved the solution for the first problem, by not creating a new font, but selecting the canvas font for displaying text, and this way i was able to change any aspect of the font, and the system cleartype settings are also applied:
// set font size for the canvas font (font style can be set the same time)
TntTreeView1.Canvas.Font.Size := 7;
// select canvas font for DC
SelectObject(DC,TntTreeView1.Canvas.Font.Handle);
// set font color
SetTextColor(DC,colortoRGB(clBlue));

Related

How to draw text in a canvas vertical + horizontal with Delphi 10.2

I want to draw on a canvas a word vertically and next to it a word horizontally.
I used a old suggestion like this :
in the maiForm's create event :
GetObject(MainForm.Font.Handle,SizeOf(TLogFont),#LogFont);
NewLogFont := LogFont;
NewLogFont.lfEscapement := 900;
NewFont := CreateFontIndirect(NewLogFont);
OldFont := MainForm.Font.Handle;
where
LogFont,NewLogFont : TLogFont;
NewFont,OldFont : HFont;
and in drawing routine :
fontTemp := TFont.Create;
fontTemp.Assign(aCanvas.Font);
......
aCanvas.Font.Handle := newFont; // if i coment this line the two strings drawn verically else both drawn horizonatlly
aCanvas.Font.Size := 8;
h := textHeight('1');
aCanvas.textOut(x,y,aString);
aCanvas.Font.Assign(fontTemp);
aCanvas.textOut(x+20,y,bString);
.....
fontTemp.Free;
In my old application (D2007) it worked ok but in Delphi 10.2, the change of orientation (from vert to horiz) changes both strings to horiz.
Any help please ?
No, as you said it is not an absolutely rare code. This approach lets you rotate text without using VCL's canvas properties.
Pure WinAPI for output text with rotation
The code below uses no VCL's capabilities to output rotated text onto provided device context (HDC).
procedure TForm1.DrawTextRotatedA(ADC: HDC; AFontHandle: HFONT;
Angle, X, Y: Integer; AColor: COLORREF; AText: String);
var
LogFont: tagLOGFONT;
OldFontHandle: HFONT;
NewFontHandle: HFONT;
begin
if (ADC = 0) or (AFontHandle = 0) then
Exit;
if GetObject(AFontHandle, SizeOf(LogFont), #LogFont) = 0 then
Exit;
// Set color of text and its rotation angle
SetTextColor(ADC, AColor);
if Angle > 360 then
Angle := 0;
LogFont.lfEscapement := Angle * 10;
LogFont.lfCharset := 1;
LogFont.lfOutPrecision := OUT_TT_PRECIS;
LogFont.lfQuality := PROOF_QUALITY;
// Create new font
NewFontHandle := CreateFontIndirect(LogFont);
try
OldFontHandle := SelectObject(ADC, NewFontHandle);
try
// Output result
SetBKMode(ADC, TRANSPARENT);
try
TextOut(ADC, X, Y, LPCWSTR(AText), Length(AText));
finally
SetBKMode(ADC, OPAQUE);
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ADC, OldFontHandle);
end;
finally
// Delete font handle
DeleteObject(NewFontHandle);
end;
end;
There are places for improvements but this is just an example to prove you are wrong calling such a code rare. This example expects HFONT as one of arguments to perform all actions over it. You probably could get font handle from TControl by using WM_GETFONT message, but most of VCL's components don't honor this message (it works, f.e. with TListView which returns correct font handle). Trying to get font handle from HDC returns System font that doesn't support rotation at all. Perhaps I did something wrong but I have acted accordingly to microsoft.docs.
Using VCL for output text with rotation
I didn't get what code you have provide in your question should to do (it is cannot be compiled) so I rewrite it to show you how to output rotated text with using VCL's capabilities.
procedure TForm1.DrawTextRotatedB(ACanvas: TCanvas; Angle, X, Y: Integer;
ATextColor: TColor; AText: String);
var
NewX: Integer;
NewY: integer;
Escapement: Integer;
LogFont: TLogFont;
NewFontHandle: HFONT;
OldFontHandle: HFONT;
begin
if not Assigned(ACanvas) then
Exit;
// Get handle of font and prepare escapement
GetObject(ACanvas.Font.Handle, SizeOf(LogFont), #LogFont);
if Angle > 360 then
Angle := 0;
Escapement := Angle * 10;
// We must initialise all fields of the record structure
LogFont.lfWidth := 0;
LogFont.lfHeight := ACanvas.Font.Height;
LogFont.lfEscapement := Escapement;
LogFont.lfOrientation := 0;
if fsBold in ACanvas.Font.Style then
LogFont.lfWeight := FW_BOLD
else
LogFont.lfWeight := FW_NORMAL;
LogFont.lfItalic := Byte(fsItalic in ACanvas.Font.Style);
LogFont.lfUnderline := Byte(fsUnderline in ACanvas.Font.Style);
LogFont.lfStrikeOut := Byte(fsStrikeOut in ACanvas.Font.Style);
LogFont.lfCharSet := ACanvas.Font.Charset;
LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFont.lfQuality := DEFAULT_QUALITY;
LogFont.lfPitchAndFamily := DEFAULT_PITCH;
StrPCopy(LogFont.lfFaceName, ACanvas.Font.Name);
// Create new font with rotation
NewFontHandle := CreateFontIndirect(LogFont);
try
// Set color of text
ACanvas.Font.Color := ATextColor;
// Select the new font into the canvas
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
try
// Output result
ACanvas.Brush.Style := VCL.Graphics.bsClear;
try
ACanvas.TextOut(X, Y, AText);
finally
ACanvas.Brush.Style := VCL.Graphics.bsSolid;
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
end;
finally
// Delete the deselected font object
DeleteObject(NewFontHandle);
end;
end;
Using case
Here is the code showing how to use procedures for rotating text.
procedure TForm1.aButton1Click(Sender: TObject);
var
DC: HDC;
begin
Repaint;
DC := GetDC(Handle);
try
DrawTextRotatedA(DC, Canvas.Font.Handle, TrackBar1.Position, 100, 100, clNavy, 'String');
finally
ReleaseDC(Handle, DC);
end;
DrawTextRotatedB(Canvas, TrackBar1.Position, 200, 100, clNavy, 'String');
end;
Sometimes it is faster to output rotated text onto DC without VCL. This could be useful if you are trying to deal with control that have no access to canvas. F.e. if you will try to paint tooltip (tooltip_class32) in your own style you probably might want to use the first method to output text (rotated or not).
Information
Here are links from docs.microsoft. they describe how and why one or another function was used.
About Device Contexts
TextOutW function
SetTextColor function
tagLOGFONTW structure
GetObject function
WM_GETFONT message
It's simple!
TFont has the property orientation that does the work! All this stuf I used is absolutely rare.

How to make text glow

Having my self-written button control (TMyButton) derived from TCustomControl I want to add an ability to make glow effect for MyButton's caption. After long time in Goolge I understood that the best way to create glow is to draw text with specify color, then blurring all - text and surface on which it is lies, and then draw text again. It will works perfectly only if surface is solid, e.g. fills with red color.
I have created procedure that make Bitmap blurred, but my button can have non-solid background, e.g bitmap which can be filled gradient. If I will blur that background it became very awful, but glow looks nice.
I suggest that this task could be solved by using Scanline, but I have no idea what exactly I should do with it.
If use solid fill I have this (filled with clWhite):
If use bitmap fill I have this ("Text" has clBlack shadow):
That is how looks blurred bitmap shown above, without blur:
Does anybody has any idea how to make glow effect for text without blurring a result bitmap?
P.S.
code to blur bitmap
procedure DrawBlurEffect(BmpInOut: TBitmap; Radius: Integer);
var
A, B, C, D: PRGBArray;
x, y, i: Integer;
begin
BmpInOut.PixelFormat := pf24bit;
for i:=0 to Radius do
begin
for y:=2 to BmpInOut.Height - 2 do
begin
A := BmpInOut.ScanLine[y-1];
B := BmpInOut.ScanLine[y];
C := BmpInOut.ScanLine[y+1];
D := BmpInOut.ScanLine[y];
for x:=1 to BmpInOut.Width - 2 do
begin
B[x].Red := Trunc(C[x].Red + A[x].Red + B[x-1].Red + D[x+1].Red) div 4;
B[x].Green := Trunc(C[x].Green + A[x].Green + B[x-1].Green + D[x+1].Green) div 4;
B[x].Blue := Trunc(C[x].Blue + A[x].Blue + B[x-1].Blue + D[x+1].Blue) div 4;
end;
end;
end;
end;
Draw text on the glass (vista and above) using DrawThemeTextEx with set DTTOPT glow flag.
uses Types, UxTheme, Themes, Graphics;
procedure DrawGlassText(Canvas: TCanvas; GlowSize: Integer; var Rect: TRect;
var Text: UnicodeString; Format: DWORD); overload;
var
DTTOpts: TDTTOpts;
begin
if Win32MajorVersion < 6 then
begin
DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Format);
Exit;
end;
ZeroMemory(#DTTOpts, SizeOf(DTTOpts));
DTTOpts.dwSize := SizeOf(DTTOpts);
DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
if Format and DT_CALCRECT = DT_CALCRECT then
DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_CALCRECT;
DTTOpts.crText := ColorToRGB(Canvas.Font.Color);
if GlowSize > 0 then
begin
DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
DTTOpts.iGlowSize := GlowSize;
end;
with ThemeServices.GetElementDetails(teEditTextNormal) do
DrawThemeTextEx(ThemeServices.Theme[teEdit], Canvas.Handle, Part, State,
PWideChar(Text), Length(Text), Format, #Rect, DTTOpts);
end;
There is TransparentCanvas that can be used to set glow color.
As a funfact :). I remember, that some components (d2) to mimic glow-effect, used simple (poor) technique - text behind with specific glow color - shadow.
procedure TExampleGlowLabel.DoDrawText( var Rect : TRect; Flags : Word );
var
Text : array[ 0..255 ] of Char;
TmpRect : TRect;
begin
GetTextBuf(Text, SizeOf(Text));
if ( Flags and DT_CALCRECT <> 0) and
( ( Text[0] = #0 ) or ShowAccelChar and
( Text[0] = '&' ) and
( Text[1] = #0 ) ) then
StrCopy(Text, ' ');
if not ShowAccelChar then
Flags := Flags or DT_NOPREFIX;
Canvas.Font := Font;
if FGlowing and Enabled then
begin
TmpRect := Rect;
OffsetRect( TmpRect, 1, 1 );
Canvas.Font.Color := GlowColor;
DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
TmpRect := Rect;
OffsetRect( TmpRect, -1, -1 );
Canvas.Font.Color := GlowColor;
DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
TmpRect := Rect;
OffsetRect( TmpRect, -1, 1 );
Canvas.Font.Color := GlowColor;
DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
TmpRect := Rect;
OffsetRect( TmpRect, 1, -1 );
Canvas.Font.Color := GlowColor;
DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
end;
Canvas.Font.Color := Font.Color;
if not Enabled then
Canvas.Font.Color := clGrayText;
DrawText(Canvas.Handle, Text, StrLen(Text), Rect, Flags);
end;
As mentioned in comment TButton with transparent PNG image and glowing hover effect has answer with some non-free components.
edit
Different approach would be to use FireMonkey Effects (really cool) TGlowEffect, but probably, it applies to whole canvas.

Position of label caption inside ProgressBar

I want to put a label inside progress bar. And this label caption is dynamic.
How can I get the label position ALWAYS on center inside the ProgressBar?
What I've tried ;
Label1.Parent := progressBar1;
Label1Top := progressBar1.Height div 2;
Label1.Left := progressBar1.Width div 2
It shows ugly, and not in center like I want.
If I set Label1.Left := progresBar1.Width div 2 - xxx it will be on center only for certain caption. I want to have any caption be placed on center.
Edited
Answer from #KenWhite is working good.
Solution from #DavidHeffernan just great.
Set the label's AutoSize property to False. Change the Alignment property to taCenter and Layout to tlCenter. Size the label to the progressbar's ClientWidth and ClientHeight, and set its Left to 0.
Label1.Parent := progressBar1;
Label1.AutoSize := False;
Label1.Transparent := True;
Label1.Top := 0;
Label1.Left := 0;
Label1.Width := progressBar1.ClientWidth;
Label1.Height := progressBar1.ClientHeight;
Label1.Alignment := taCenter;
Label1.Layout := tlCenter;
Here's an example of the appearance:
You might decide to derive a progress bar control that paints the text itself rather than relying on a separate label. Some sample code to demonstrate:
type
TProgressBarWithText = class(TProgressBar)
private
FProgressText: string;
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
published
property ProgressText: string read FProgressText write FProgressText;
end;
procedure TProgressBarWithText.WMPaint(var Message: TWMPaint);
var
DC: HDC;
prevfont: HGDIOBJ;
prevbkmode: Integer;
R: TRect;
begin
inherited;
if ProgressText <> '' then
begin
R := ClientRect;
DC := GetWindowDC(Handle);
prevbkmode := SetBkMode(DC, TRANSPARENT);
prevfont := SelectObject(DC, Font.Handle);
DrawText(DC, PChar(ProgressText), Length(ProgressText),
R, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
SelectObject(DC, prevfont);
SetBkMode(DC, prevbkmode);
ReleaseDC(Handle, DC);
end;
end;
The advantage of this approach is that your progress bar and text display are self-contained. There's no need for two separate controls that you have to coordinate.

Avoid TListView drawing/updating while mouse hovering/over

I have a TListView with some modifications. It includes some icons (several, depending on the item) per row, as well as the possibility of a background for a row if certain conditions are met.
It seems to be rendering all right. But a problem occurs when I move the mouse over the window, it seems like the rows are being re-rendered, this creates an unnecessary lag and more importantly, it seems to mess with the visualisation. It should only re-draw if I do something (like select a row).
How do I force it to stop (seemingly refreshing rows upon mouse over)? Currently I am using the AdvancedCustomDrawItem to draw. It also takes like a second for the window to react to a selection of an item, that seems dull.
So basically, each row has DrawText() and drawing images onto the Sender.Canvas. This is admittedly a slow progress, but it works for now, if it just didn't seemingly redraw the rows when I hover over them! In fact, if I use the Aero theme, the rows become black when you hover over them.
Here is my event code on AdvancedCustomDrawItem:
procedure TfrmJobQueue.ListView1AdvancedCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
var DefaultDraw: Boolean);
const
DT_ALIGN: array[TAlignment] of integer = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
r: TRect;
SL: TStringList;
TypeName: string;
I: Integer;
TypeState: integer;
x1,x2: Integer;
S: string;
begin
if Stage = cdPostPaint then begin
// Ways I tried to avoid it; but failed.
if cdsHot in State then
exit;
if cdsNearHot in State then
exit;
if cdsOtherSideHot in State then
exit;
if cdsMarked in State then
exit;
if cdsIndeterminate in State then
exit;
Sender.Canvas.Brush.Style := bsSolid;
if FRepLines.Items[Item.Index].IsAutoReport then begin
Sender.Canvas.Font.Color := clBlack;
Sender.Canvas.Brush.Color := clSkyBlue;
end else begin
Sender.Canvas.Font.Color := clBlack;
Sender.Canvas.Brush.Color := clWhite;
end;
if cdsSelected in State then begin
Sender.Canvas.Font.Color := clWhite;
Sender.Canvas.Brush.Color := clNavy;
end;
R := Item.DisplayRect(drBounds);
Sender.Canvas.FillRect(R);
Sender.Canvas.Brush.Style := bsClear;
if cdsFocused in State then
DrawFocusRect(Sender.Canvas.Handle, R);
x1 := 0;
x2 := 0;
for i := 0 to TListView(Sender).Columns.Count - 1 do
begin
inc(x2, Sender.Column[i].Width);
r.Left := x1;
r.Right := x2;
if i = 0 then
S := Item.Caption
else
S := Item.SubItems[i-1];
if DT_ALIGN[Sender.Column[i].Alignment] = DT_LEFT then
S := ' ' + S;
DrawText(Sender.Canvas.Handle,
S, length(S), r,
DT_SINGLELINE or DT_ALIGN[Sender.Column[i].Alignment] or
DT_VCENTER or DT_END_ELLIPSIS);
x1 := x2;
end;
r := Item.DisplayRect(drIcon);
SL := TStringList.Create;
SL.CommaText := FRepLines.Value(Item.Index, 'TypeState');
r.Left := Sender.Column[0].Width + Sender.Column[1].Width + Sender.Column[2].Width + Sender.Column[3].Width
+ Sender.Column[4].Width;
for I := 0 to SL.Count - 1 do begin
if GetTypeImagesIndex(SL.Names[I]) = -1 then
continue;
// FRepLines is a collection of items containing more information about each row.
if FRepLines.Value(Item.Index, 'State') <> '1' then begin // no error
TypeName := SL.Names[I];
TypeState := StrToIntDef(SL.Values[TypeName], 0);
// State*Images are TImageList.
if TypeState = 0 then
StateWaitingImages.Draw(Sender.Canvas, r.Left + 17*I, r.Top,
GetTypeImagesIndex(TypeName))
else
StateDoneImages.Draw(Sender.Canvas, r.Left + 17*I, r.Top,
GetTypeImagesIndex(TypeName));
CreateIconToolTip(StrToIntDef(FRepLines.Value(Item.Index, 'RepJob'), -1),
TypeName, r.Left + 17*I, ListView1.ViewOrigin.Y + r.Top,
Format(TranslateString('RepQTypeState'),
[TranslateString(Format('RepQTypeStateN%s', [TypeName])),
TranslateString(Format('RepQTypeState-%d', [TypeState]))]));
end;
end;
end;
end;
Some explanation of the code:
The list is a list of reports (a report queue). I am introducing a concept of 'AutoReports' (or scheduled reports in the UI), which I want to highlight with a light blue background (clSkyBlue).
In addition to that background, it also draws some icons on the Status-column, which indicates what stages the report are in and moreover, what formats a report has been ordered in (formats like PDF, Excel and HTML), and whether it has been printed and/or emailed. An icon only appears if such an event has been ordered, so the number of icons are variable.
The waiting state images are greyed out versions of the done state images. I have also tried to create some code, so when I hover over the specific icons, it has a tooltip message.
Because the code is rather dull in speed, I suspect I am doing something incredibly wrong.
HotTracking is likely enabled. That causes items to redraw as they are moused over, so the item under the mouse can be rendered differently. You are probably ignoring the hottrack state when drawing. That could account for the blackness.
You should profile your code to find the real bottleneck. Drawing code needs to be fast. I do a lot of custom drawing in a ListView and it does not behave slowly like you describe.
Update: Consider re-writing your code to draw individual columns in the OnAdvancedCustomDrawSubItem event instead of doing everything in the OnAdvancedCustomDrawItem event. Also, you don't need to calculate each column's bounds manually, you can use ListView_GetSubItemRect() instead. And lastly, you are leaking your TStringList.

How to set size of inactive (hidden) dock clients' tabs in JVCL Docking component?

The only dock style in JVCL that I know that has the auto hide function (to pin the dock clients) is JvDockVSNetStyle. I'm using it but I can't set the size of the inactive pinned panes' tabs. When hidden, the tabs don't show the title of the pane, only the name of the active pane is shown. Sorry, I can't post an example image because that's my first question.
In the object inpector there is an option called ChannelOption with the ActivePaneSize property. Is there a way to set the inactive pane size so it can show its name? Or maybe there is another dock style that I'm missing that has the same functions?
I'm using C++Builder and JVCL 3.45.
i did it by commenting out these code parts:
procedure TJvDockVSChannel.GetBlockRect(Block: TJvDockVSBlock; Index: Integer;
var ARect: TRect);
var
BlockWidth: Integer;
begin
// HERE
// if Block.VSPane[Index] <> Block.ActivePane then
// BlockWidth := Block.InactiveBlockWidth
// else
BlockWidth := Block.ActiveBlockWidth;
<snip>
procedure TJvDockVSChannel.Paint;
var
I: Integer;
<snip>
begin
VisiblePaneCount := 0;
for I := 0 to Block.VSPaneCount - 1 do
begin
if not Block.VSPane[I].FVisible then
Continue;
GetBlockRect(Block, I, DrawRect);
Canvas.Brush.Color := TabColor;
Canvas.FillRect(DrawRect);
Canvas.Brush.Color := clGray;
Canvas.FrameRect(DrawRect);
AdjustImagePos;
Block.FImageList.Draw(Canvas, DrawRect.Left, DrawRect.Top, I, dsTransparent, itImage);
// HERE
// if Block.ActivePane = Block.VSPane[I] then
begin
if Align in [alTop, alBottom] then
Inc(DrawRect.Left, Block.InactiveBlockWidth)
else
if Align in [alLeft, alRight] then
begin
Inc(DrawRect.Top, Block.InactiveBlockWidth);
if Align = alLeft then
DrawRect.Left := 15
else
DrawRect.Left := 20;
DrawRect.Right := DrawRect.Left + (DrawRect.Bottom - DrawRect.Top);
end;
Canvas.Brush.Color := TabColor;
Canvas.Pen.Color := clBlack;
Dec(DrawRect.Right, 3);
OldGraphicsMode := SetGraphicsMode(Canvas.Handle, GM_ADVANCED);
Canvas.Brush.Style := bsClear;
// HERE (changed options)
DrawText(Canvas.Handle, PChar(Block.VSPane[I].FDockForm.Caption), -1, DrawRect, {DT_END_ELLIPSIS or} DT_NOCLIP);
There is an event in TJvDockServer called DoFinishSetDockPanelSize.
Within the function you create for that event you can access the size of a form using Dockpanel. There may be a way from here to set the size of the tabs.

Resources