I want the currency values in the TStringGrid table to have different color decimals. How can do that?
You need to draw the cells yourself by implementing an OnDrawCell handler.
Something like this:
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
Grid: TStringGrid;
S: string;
Val: Double;
FracVal, IntVal: Integer;
FracStr, IntStr: string;
IntW, FracW, W, H: Integer;
Padding: Integer;
const
PowersOfTen: array[0..8] of Integer =
(
1,
10,
100,
1000,
10000,
100000,
1000000,
10000000,
100000000
);
Decimals = 2;
BgColor = clWhite;
IntColor = clBlack;
FracColor = clRed;
begin
Grid := Sender as TStringGrid;
if (ACol < Grid.FixedCols) or (ARow < Grid.FixedRows) then
Exit;
Grid.Canvas.Brush.Color := BgColor;
Grid.Canvas.FillRect(Rect);
S := Grid.Cells[ACol, ARow];
Padding := Grid.Canvas.TextWidth('0') div 2;
if not TryStrToFloat(S, Val) or not InRange(Val, Integer.MinValue, Integer.MaxValue) then
begin
Grid.Canvas.TextRect(Rect, S, [tfSingleLine, tfVerticalCenter, tfLeft]);
Exit;
end;
IntVal := Trunc(Val);
IntStr := IntVal.ToString;
if Decimals > 0 then
IntStr := IntStr + FormatSettings.DecimalSeparator;
IntW := Grid.Canvas.TextWidth(IntStr);
FracVal := Round(Frac(Abs(Val)) * PowersOfTen[Decimals]);
FracStr := FracVal.ToString.PadRight(Decimals, '0');
if Decimals = 0 then
FracStr := '';
FracW := Grid.Canvas.TextWidth(FracStr);
W := IntW + FracW;
H := Grid.Canvas.TextHeight(IntStr);
if W >= Grid.ColWidths[ACol] - 2*Padding then
begin
S := '###';
Grid.Canvas.TextRect(Rect, S, [tfSingleLine, tfVerticalCenter, tfRight]);
end
else
begin
Grid.Canvas.Font.Color := IntColor;
Grid.Canvas.TextOut(Rect.Right - Padding - W,
Rect.Top + Rect.Height div 2 - H div 2, IntStr);
Grid.Canvas.Font.Color := FracColor;
Grid.Canvas.TextOut(Rect.Right - Padding - FracW,
Rect.Top + Rect.Height div 2 - H div 2, FracStr);
end;
end;
This code will write non-numeric data left-aligned as is. For numeric data, it will draw the values with a fixed number of decimals. You can choose the decimals (0..8), as well as the colours of the integral and fractional parts. If the number doesn't fit in its cell, ### will be displayed instead.
I haven't fully tested the code. I'll leave that to you as an exercise.
Update: Sorry, I forgot you are using Delphi 7. This means that you need to replace IntVal.ToString with IntToStr(IntVal) and so on.
Related
Background: I have created a maze game that is playable, however when the maze gets bigger there are more chances to go wrong and takes ages to reach the start of the maze again, I've been told that's really annoying.
Question: I want to create a pause game function that when the user presses the button key a menu pops up that allows the user to be able to either return to main menu or restart the maze.
I have very little knowledge on where to start this in the code as I don't want to mess up anything that has already been added.
I've added the draw maze //creates the maze,
initialise visited and walk // removes the walls of the maze,
Form key down//moves the player
and Timer//collision detection procedures below.
hopefully someone can help?
Many Thanks.
`procedure TfrmMazeDesign.draw_maze(square_size: integer);
var
row, col : integer;
begin
// setup default walls as "WWWW" wall on all four sides.
SetLength(Shapes,height+3, width+3, 2 ) ;
for row := 1 to height do
begin
for col := 1 to width+2 do
begin
Shapes[row,col,0]:= TShape.Create(Self);
Shapes[row,col,0].Parent := Self;
with Shapes[row,col,0] do
begin
Width := 5;
Height := square_size;
Left := 100+ ((col-1) * square_size);
Top := 50+ ((row-1) * square_size);
Brush.Color := RGB(255, 255,25);
Shape := stRectangle;
end;
end;
end;
for row := 1 to height+1 do
begin
for col := 1 to width+1 do
begin
Shapes[row,col,1]:= TShape.Create(Self);
Shapes[row,col,1].Parent := Self;
with Shapes[row,col,1] do
begin
Width := square_size;
Height := 5;
Left := 100+ ((col-1) * square_size);
Top := 50+ ((row-1) * square_size);
Brush.Color := RGB(255, 255,25);
Shape := stRectangle;
end;
end;
end;
end;
procedure TfrmMazeDesign.initialise_visited(var visited: Tvisited);
var
row, col: integer;
begin
for row := 0 to height+2 do
for col := 0 to width+2 do
if (col = 0) or (row = 0) or (row = height+1) or (col= width+2) then
visited[row,col] := True
else
visited[row,col] := False;
end;
procedure TFrmMazeDesign.walk(visited: Tvisited; x: integer; y:integer);
var
xx,yy, counter, ran_direction: integer;
direction: Tstringlist; // 1= Up, 2= right, 3 = down, 4 = left
text: string;
begin
visited[x,y] := True;
direction := TStringlist.Create;
direction.Add('1');
direction.Add('2');
direction.Add('3');
direction.Add('4');
for counter := direction.Count - 1 downto 0 do
direction.Exchange(counter, Random(counter+1));
for counter := 0 to direction.Count-1 do
begin
ran_direction := StrtoInt(direction[counter]);
if ran_direction= 1 then
begin
xx := x-1;
yy := y
end;
if ran_direction = 2 then
begin
xx := x+1;
yy := y
end;
if ran_direction = 3 then
begin
xx := x;
yy := y-1
end;
if ran_direction= 4 then
begin
xx := x;
yy := y+1
end;
if visited[xx,yy] = False then
begin
if xx = x then
shapes[x,Max(yy,y),0].visible := False;
if yy = y then
shapes[Max(xx,x),y,1].visible := False;
walk (visited, xx,yy)
end;
end;
end;
procedure TfrmMazeDesign.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_UP:
direction := 1;
VK_DOWN:
direction := 2;
VK_LEFT:
direction := 3;
VK_RIGHT:
direction := 4;
end;
end;
procedure TfrmMazeDesign.FormOpen(Sender: TObject);
var
block_height: integer;
xx,yy: integer;
visited: Tvisited;
monster, monster2: TMonster;
Shape_height : integer;
Shape_Width : integer;
imgfinish_height : integer;
maze_width : integer;
begin
width := frmdifficulty.ScrollBar1.Position;
height := frmdifficulty.ScrollBar1.Position;
maze_width := 650;
block_height := maze_width div width;
Shape_height := round( block_height * 0.5);
imgfinish_height := round(block_height * 0.5);
draw_maze(block_height);
SetLength(visited, height+10, width+10) ;
initialise_visited(visited);
walk(visited,3,3);
ShpUser.height := Shape_height;
ShpUser.Width := Shape_height;
imgfinish.width := Shape_height;
imgfinish.height := shape_height;
ShpUser.Shape := UShapeEditor.frmShape.shpShape.Shape;
ShpUser.Brush.color := UShapeEditor.frmShape.shpShape.Brush.color;
FDateTimeTo := StrToDateTime(FormatDateTime('dd' + FormatSettings.DateSeparator + 'mm' +
FormatSettings.DateSeparator + 'yyyy', Now)); Incsecond(time,120);
Timer1.Enabled := True;
monster := TMonster.Create(Self);
monster.Parent := Self;
monster.SetSizes(width, height, shape_height, 55+ maze_width + 10,665);
monster.start;
monster2 := TMonster.Create(Self);
monster2.Parent := Self;
monster2.SetSizes(width, height, shape_height, 50+ maze_width + 10,565);
monster2.start;
end;
procedure TfrmMazeDesign.Timer1Timer(Sender: TObject);
var IntersectionRect: TRect;
collision, test_collision : boolean;
up : boolean;
right : boolean;
max_width, max_height : integer;
xx, yy : integer ;
aRect1: TRect;
buttonSelected : Integer;
collisionend: boolean;
frmMazeDesign: TfrmMazeDesign;
row, col, hoz_vert : integer;
begin
hoz_vert := 0;
xx := 0;
yy := 0;
case direction of
1:begin //Up
yy := -3;
end;
2: begin //down
yy := + 3;
end;
3: begin //left
xx := -3;
end;
4: begin //right
xx := + 3;
end;
end;
repeat
if hoz_Vert = 0 then begin
max_width := width +3;
max_height := Height+1;
end else begin
max_width := width+2;
max_height := Height+2;
end;
row := 1;
repeat
col := 1;
repeat
aRect1 := Rect(ShpUser.Left+xx, ShpUser.Top+yy, ShpUser.Left+ShpUser.width+xx, ShpUser.top+ ShpUser.Height+yy);
if Shapes[row,col,hoz_vert].visible = True then
collision := IntersectRect(IntersectionRect, aRect1, Shapes[row,col,hoz_vert].BoundsRect) ;
col := col + 1;
until (collision) or (col = max_width);
row := row + 1 ;
until (collision) or (row = max_height);
hoz_vert := hoz_vert +1;
until (collision) or (hoz_vert = 2);
if (collision = False) and (direction <> 0) then begin
ShpUser.Top := ShpUser.Top + yy;
ShpUser.Left := ShpUser.Left + xx;
end;
if IntersectRect(IntersectionRect, imgfinish.BoundsRect, Shpuser.BoundsRect) then
begin
Collisionend := true;
if collisionend = true then
frmfinish.Show;
direction:= 0;
end;`
This is relatively straightforward to add to your program, which is already event driven. In summary you need to do the following:
Add a Boolean flag, perhaps named Paused, set to False when the game starts.
When the user presses the pause button, set the Paused flag to True.
When the user presses the resume button, set the Paused flag to False.
In the time event handler, check the Paused flag before updating the positions. If the Paused flag is True, then simply exit from the timer event handler before doing anything else.
I want to disable the gridlines in a drawgrid and draw the grid lines myself for every other columns. Row lines are not needed.
I want to merge two cells in the fixed area so that it looks like as it is one column, like in this picture:
I have added this code to the ondrawcell event of the drawgrid to achieve this:
procedure Tbookings3_Frm.bgridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
CellIndex: Integer;
s:string;
x:integer;
begin
CellIndex := (ARow * bgrid.ColCount) + ACol;
if gdFixed in State then
begin
bgrid.Canvas.Brush.Color := clskyblue;
end
else if (State * [gdSelected, gdHotTrack]) <> [] then
begin
bgrid.Canvas.Brush.Color := clHighlight;
end
else
begin
bgrid.Canvas.Brush.Color := Cells[CellIndex].BkColor;
end;
bgrid.Canvas.FillRect(Rect);
if gdFixed in State then
Frame3D(bgrid.Canvas, Rect, clHighlight, clBtnShadow, 1);
if gdFocused in State then
bgrid.Canvas.DrawFocusRect(Rect);
//---------------
with (Sender as TDrawGrid).Canvas do
begin
// set font
Font.Color := CLblack;
FillRect(Rect);
if ARow = 2 then
begin
x := (Rect.Right - Rect.Left - TextWidth(days_h[ACol])) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, days_h[ACol]);
end;
if ARow = 1 then
begin
x := (Rect.Right - Rect.Left - TextWidth(sun_mon[ACol])) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, sun_mon[ACol]);
end;
if ARow = 0 then
begin
x := (Rect.Right - Rect.Left - TextWidth(mon[ACol])) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, mon[ACol]);
end;
if (Acol = 0) and (ARow > 2) then
begin
s:=rooms[Arow];
x := (Rect.Right - Rect.Left - TextWidth(s)) div 2;
TextOut(Rect.Left + x, Rect.Top + 2, s);
end;
//-------------------------------------------------
end; //end canvas
//----------------
if gdFocused in State then
bgrid.Canvas.DrawFocusRect(Rect);
end;
You need to disable the grid's native gridlines, and then you can draw your own gridlines surrounding each cell in the OnDrawCell event as needed. The TRect represents the inside area of the cell being drawn, but you can draw outside of that Rect as well. To make two cells appear merged, you would simply not draw a gridline between them.
I want to make a kind of multi-color bar in my software. A kind of progressbar, but with two current values.
That's why I need it.
I have some "budget parts", and each one of them has its own limit (100$, 1000$ etc.)
I also have an editing form for adding new bills (and linking bills to budget parts).
In this editor I want to visually represent how full is a budget part, and how much price of current bill affects this budget part.
For example, the whole bar is 100$.
Green part means sum of prices across saved bills, for example 60$.
Yellow part means price of the current bill, which is not saved yet, for example 5$.
Like this:
Of course, values should be set dynamically.
Can you recommend me any components for drawing this (maybe some advanced progressbar, that can display more than one current value?)
As David suggests, just paint it yourself. Just about the same amount of trouble. Drop a TImage where you want your gauge and use something like this:
procedure PaintTwoColorGauge(const BackgroundColor, BorderColor, FirstGaugeColor, SecondGaugeColor: TColor; FirstGaugeValue, SecondGaugeValue, TotalValue: Integer; const Img: TImage);
var B: TBitmap;
ImgWidth, G1Width, G2Width: Integer;
begin
B := TBitmap.Create;
try
B.Width := Img.Width;
B.Height := Img.Height;
B.Canvas.Brush.Color := BackgroundColor;
B.Canvas.Brush.Style := bsSolid;
B.Canvas.Pen.Style := psClear;
B.Canvas.Pen.Width := 1;
B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
if TotalValue <> 0 then
begin
ImgWidth := B.Width - 2; // Don't account the width of the borders.
G1Width := (FirstGaugeValue * ImgWidth) div TotalValue;
G2Width := (SecondGaugeValue * ImgWidth) div TotalValue;
if G1Width > ImgWidth then G1Width := ImgWidth; // Just in case
if G2Width > ImgWidth then G2Width := ImgWidth;
if G2Width > G1Width then
begin
B.Canvas.Brush.Color := SecondGaugeColor;
B.Canvas.FillRect(Rect(0, 0, G2Width, B.Height));
B.Canvas.Brush.Color := FirstGaugeColor;
B.Canvas.FillRect(Rect(0, 0, G1Width, B.Height));
end
else
begin
B.Canvas.Brush.Color := FirstGaugeColor;
B.Canvas.FillRect(Rect(0, 0, G1Width, B.Height));
B.Canvas.Brush.Color := SecondGaugeColor;
B.Canvas.FillRect(Rect(0, 0, G2Width, B.Height));
end;
end;
B.Canvas.Pen.Color := BorderColor;
B.Canvas.Pen.Style := psSolid;
B.Canvas.Brush.Style := bsClear;
B.Canvas.Rectangle(0, 0, B.Width, B.Height);
Img.Picture.Assign(B);
finally B.Free;
end;
end;
For example, here's what this code does to my 3 TImages (my images are intentionally shpaed as you see them):
procedure TForm1.FormCreate(Sender: TObject);
begin
PaintTwoColorGauge(clWhite, clBlack, clGreen, clYellow, 50, 55, 100, Image1);
PaintTwoColorGauge(clWhite, clBlack, clGreen, clYellow, 50, 60, 100, Image2);
PaintTwoColorGauge(clWhite, clBlack, clGreen, clYellow, 20, 60, 100, Image3);
end;
Write your own, it's fun! But while not really thát difficult, writing an own component could look like a daunting task. Especially for novice uses or without experience doing so.
Next in line of options is to draw it yourself, and the therefore intended component should "always" be the TPaintBox control. Implement the OnPaint event handler and it redraws itself when needed. Here an example implementation of how to transform such a paint box into a double gauge component:
type
TDoubleGauge = record
BackgroundColor: TColor;
BorderColor: TColor;
Color1: TColor;
Color2: TColor;
Value1: Integer;
Value2: Integer;
MaxValue: Integer;
end;
TForm1 = class(TForm)
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
FDoubleGauge: TDoubleGauge;
end;
...
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
Box: TPaintBox absolute Sender;
MaxWidth: Integer;
Width1: Integer;
Width2: Integer;
begin
with FDoubleGauge do
begin
Box.Canvas.Brush.Color := BackgroundColor;
Box.Canvas.Pen.Color := BorderColor;
Box.Canvas.Rectangle(0, 0, Box.Width, Box.Height);
if MaxValue <> 0 then
begin
MaxWidth := Box.Width - 2;
Width1 := (MaxWidth * Value1) div MaxValue;
Width2 := (MaxWidth * Value2) div MaxValue;
Box.Canvas.Brush.Color := Color2;
if Abs(Value2) < Abs(MaxValue) then
Box.Canvas.FillRect(Rect(1, 1, Width2, Box.Height - 1));
Box.Canvas.Brush.Color := Color1;
if Abs(Value1) < Abs(Value2) then
Box.Canvas.FillRect(Rect(1, 1, Width1, Box.Height - 1));
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FDoubleGauge.BackgroundColor := clWhite;
FDoubleGauge.BorderColor := clBlack;
FDoubleGauge.Color1 := clGreen;
FDoubleGauge.Color2 := clYellow;
FDoubleGauge.Value1 := 50;
FDoubleGauge.Value2 := 60;
FDoubleGauge.MaxValue := 100;
PaintBox1.Invalidate;
end;
Well, that looks like quite an effort. Especially when there are more of such doudble gauges needed on a single form. Therefore I like Cosmin Prund's answer, because he uses TImage components which are capable of "memorizing" what has to be redrawn when needed. Just as a bonus, here an alternative version of his code (with slightly different behaviour on invalid input):
procedure DrawDoubleGauge(BackgroundColor, BorderColor, Color1, Color2: TColor;
Value1, Value2, MaxValue: Integer; Img: TImage);
var
Width: Integer;
Width1: Integer;
Width2: Integer;
begin
Img.Canvas.Brush.Color := BackgroundColor;
Img.Canvas.Pen.Color := BorderColor;
Img.Canvas.Rectangle(0, 0, Img.Width, Img.Height);
if MaxValue <> 0 then
begin
Width := Img.Width - 2;
Width1 := (Width * Value1) div MaxValue;
Width2 := (Width * Value2) div MaxValue;
Img.Canvas.Brush.Color := Color2;
if Abs(Value2) < Abs(MaxValue) then
Img.Canvas.FillRect(Rect(1, 1, Width2, Img.Height - 1));
Img.Canvas.Brush.Color := Color1;
if Abs(Value1) < Abs(Value2) then
Img.Canvas.FillRect(Rect(1, 1, Width1, Img.Height - 1));
end;
end;
I was also looking for this exactly, as I don't want to spend any money on this I will follow the proposed solution, nevertheless if anyone would like an advanced component I found one that's not too expensive and look pretty decent in my opinion, here's the link in case it could be useful for someone else:
http://www.tmssoftware.com/site/advprogr.asp?s=
Thank's to all.
Any library/code to fade the edges of a bitmap in a gradient manner?
Something like this:
Edit: final code
Ok came up with this code after your example, it's ~10 times faster after optimization with scanlines. Ideally I think I should convert it to use a 32bit bitmap instead and modify the actual alpha layer, but this works for now, ty!
procedure FadeEdges(b: TBitmap; Depth, Start, Col: TColor);
Var f, x, y, i: Integer;
w,h: Integer;
pArrays: Array of pRGBArray;
xAlpha: Array of byte;
sR, sG, sB: Byte;
a,a2: Double;
r1,g1,b1: Double;
Lx,Lx2: Integer;
procedure AlphaBlendPixel(X, Y: Integer);
begin
pArrays[y,x].rgbtRed := Round(r1 + pArrays[y,x].rgbtRed * a2);
pArrays[y,x].rgbtGreen := Round(g1 + pArrays[y,x].rgbtGreen * a2);
pArrays[y,x].rgbtBlue := Round(b1 + pArrays[y,x].rgbtBlue * a2);
end;
procedure AlphaBlendRow(Row: Integer; Alpha: Byte);
Var bR, bG, bB, xA: Byte;
t: Integer;
s,s2: Double;
begin
s := alpha / 255;
s2 := (255 - Alpha) / 255;
for t := 0 to b.Width-1 do begin
bR := pArrays[Row,t].rgbtRed;
bG := pArrays[Row,t].rgbtGreen;
bB := pArrays[Row,t].rgbtBlue;
pArrays[Row,t].rgbtRed := Round(sR*s + bR*s2);
pArrays[Row,t].rgbtGreen := Round(sG*s + bG*s2);
pArrays[Row,t].rgbtBlue := Round(sB*s + bB*s2);
end;
end;
begin
b.PixelFormat := pf24bit;
// cache scanlines
SetLength(pArrays,b.Height);
for y := 0 to b.Height-1 do
pArrays[y] := pRGBArray(b.ScanLine[y]);
// pre-calc Alpha
SetLength(xAlpha,Depth);
for y := 0 to (Depth-1) do
xAlpha[y] := Round(Start + (255 - Start)*y/(Depth-1));
// pre-calc bg color
sR := GetRValue(Col);
sG := GetGValue(Col);
sB := GetBValue(Col);
// offsets
w := b.Width-Depth;
h := b.Height-Depth;
for i := 0 to (Depth-1) do begin
a := xAlpha[i] / 255;
a2 := (255 - xAlpha[i]) / 255;
r1 := sR * a;
g1 := sG * a;
b1 := sB * a;
Lx := (Depth-1)-i;
Lx2 := i+w;
for y := 0 to b.Height - 1 do begin
AlphaBlendPixel(Lx, y); // Left
AlphaBlendPixel(Lx2, y); // right
end;
end;
for i := 0 to (Depth-1) do begin
AlphaBlendRow((Depth-1)-i, xAlpha[i]); // top
AlphaBlendRow(i+(h), xAlpha[i]); // bottom
end;
SetLength(xAlpha,0);
SetLength(pArrays,0);
end;
Final result: (left = original, right = blended on hovering with a ListView)
edit: further speed improvements, twice as fast as original proc.
I can give you some code I wrote a couple of years ago to achieve this. It might be useful as a guide. The code is part of a class that manipulates a bitmap and this is the part that fades the left edge of the bitmap into a white background:
procedure TScreenShotEnhancer.FadeOutLeft(Position, Start: Integer);
var
X, Y: Integer;
F, N: Integer;
I: Integer;
begin
BeginUpdate;
try
N := Position;
for I := 0 to N - 1 do begin
X := Position - I - 1;
F := Round(Start + (255 - Start)*I/N);
for Y := 0 to Height - 1 do
AlphaBlendPixel(X, Y, clWhite, F);
end;
finally
EndUpdate;
end;
end;
The actual work is done in this method:
procedure TScreenShotEnhancer.AlphaBlendPixel(X, Y: Integer; Color: TColor;
Alpha: Byte);
var
backgroundColor: TColor;
displayColor: TColor;
dR, dG, dB: Byte;
bR, bG, bB: Byte;
sR, sG, sB: Byte;
begin
backgroundColor := Bitmap.Canvas.Pixels[X, Y];
bR := GetRValue(backgroundColor);
bG := GetGValue(backgroundColor);
bB := GetBValue(backgroundColor);
sR := GetRValue(Color);
sG := GetGValue(Color);
sB := GetBValue(Color);
dR := Round(sR * alpha / 255 + bR * (255 - alpha) / 255);
dG := Round(sG * alpha / 255 + bG * (255 - alpha) / 255);
dB := Round(sB * alpha / 255 + bB * (255 - alpha) / 255);
displayColor := RGB(dR, dG, dB);
Bitmap.Canvas.Pixels[X, Y] := displayColor;
end;
When designing a form in the IDE, non-visual components (eg TMainMenus, TDatamodules) can be freely placed and positioned. The position is persisted, so that on reloading the form these components appear in the correct place.
But, TComponent does not have Top or Left properties!
So, how can my code access the 'designed position' of non visual components?
This can be accessed at runtime, but it's sort of a hack. (Mostly because it's implemented as sort of a hack.)
The Left and Top properties are set up as Word-size values, and the two of them are packed together into a Longint called TComponent.FDesignInfo. You can obtain its value with the DesignInfo property. Have a look at TComponent.DefineProperties to get a look into how it's used.
And also:
How to set DesignInfo to a point like (-100,-100)?
Objective: Put the icon out of visual area, hide it on design-time.
Note: It is very usefull when for example creating simple visual components derived directly from TComponent, i have in mind a very simple label (taht is allways aligned to top, has allways left=0, top is auto-calculated, bla bla bla) that only stores it's caption property into the .dfm file; and also any localizer will only see that caption property.
SOLUTION is to Override ReadState with code like this:
procedure TMyComponent.ReadState(Reader:TReader);
var
NewDesignInfo:LongRec;
begin
inherited ReadState(Reader);
NewDesignInfo.Hi:=Word(-100); // Hide design-time icon (top position = -100)
NewDesignInfo.Lo:=Word(-100); // Hide design-time icon (left position = -100)
DesignInfo:=Longint(NewDesignInfo); // Set the design-icon position out of visual area
end;
Hope help others!
This worked for me. Source: CnPack CnAlignSizeWizard.pas.
procedure SetNonVisualPos(Form: TCustomForm; Component: TComponent; X, Y: Integer);
const
NonvisualClassNamePattern = 'TContainer';
csNonVisualSize = 28;
csNonVisualCaptionSize = 14;
csNonVisualCaptionV = 30;
var
P: TSmallPoint;
H1, H2: HWND;
Offset: TPoint;
function HWndIsNonvisualComponent(hWnd: hWnd): Boolean;
var
AClassName: array[0..256] of Char;
begin
AClassName[GetClassName(hWnd, #AClassName, SizeOf(AClassName) - 1)] := #0;
Result := string(AClassName) = NonvisualClassNamePattern;
end;
procedure GetComponentContainerHandle(AForm: TCustomForm; L, T: Integer; var H1, H2: hWnd; var Offset: TPoint);
var
R1, R2: TRect;
P: TPoint;
ParentHandle: hWnd;
AControl: TWinControl;
I: Integer;
begin
ParentHandle := AForm.Handle;
AControl := AForm;
if AForm.ClassNameIs('TDataModuleForm') then // ÊÇ DataModule
begin
for I := 0 to AForm.ControlCount - 1 do
if AForm.Controls[I].ClassNameIs('TComponentContainer')
and (AForm.Controls[I] is TWinControl) then
begin
AControl := AForm.Controls[I] as TWinControl;
ParentHandle := AControl.Handle;
Break;
end;
end;
H2 := 0;
H1 := GetWindow(ParentHandle, GW_CHILD);
H1 := GetWindow(H1, GW_HWNDLAST);
while H1 <> 0 do
begin
if HWndIsNonvisualComponent(H1) and GetWindowRect(H1, R1) then
begin
P.x := R1.Left;
P.y := R1.Top;
P := AControl.ScreenToClient(P);
if (P.x = L) and (P.y = T) and (R1.Right - R1.Left = csNonVisualSize)
and (R1.Bottom - R1.Top = csNonVisualSize) then
begin
H2 := GetWindow(ParentHandle, GW_CHILD);
H2 := GetWindow(H2, GW_HWNDLAST);
while H2 <> 0 do
begin
if HWndIsNonvisualComponent(H2) and GetWindowRect(H2, R2) then
begin
if (R2.Top - R1.Top = csNonVisualCaptionV) and (Abs(R2.Left + R2.Right - R1.Left - R1.Right) <= 1)
and (R2.Bottom - R2.Top = csNonVisualCaptionSize) then
begin
Offset.x := R2.Left - R1.Left;
Offset.y := R2.Top - R1.Top;
Break;
end;
end;
H2 := GetWindow(H2, GW_HWNDPREV);
end;
Exit;
end;
end;
H1 := GetWindow(H1, GW_HWNDPREV);
end;
end;
begin
P := TSmallPoint(Component.DesignInfo);
GetComponentContainerHandle(Form, P.x, P.y, H1, H2, Offset);
Component.DesignInfo := Integer(PointToSmallPoint(Point(X, Y)));
if H1 <> 0 then
SetWindowPos(H1, 0, X, Y, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
if H2 <> 0 then
SetWindowPos(H2, 0, X + Offset.x, Y + Offset.y, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
end;
Use sample:
SetNonVisualPos(TCustomForm(Designer.Root),MyComponent,10,10);