Unexpected behavior of command history unit - delphi

I wrote such module to store there last changes of picture in my paint application " in Delphi
unit HistoryQueue;
interface
uses
Graphics;
type
myHistory = class
constructor Create(Size:Integer);
public
procedure Push(Bmp:TBitmap);
function Pop():TBitmap;
procedure Clean();
procedure Offset();
function isEmpty():boolean;
function isFull():boolean;
function getLast():TBitmap;
protected
historyQueueArray: array of TBitmap;
historyIndex, hSize:Integer;
end;
implementation
procedure myHistory.Push(Bmp:TBitmap);
var tbmp:TBitmap;
begin
if(not isFull) then begin
Inc(historyIndex);
historyQueueArray[historyIndex]:=TBitmap.Create;
historyQueueArray[historyIndex].Assign(bmp);
end else begin
Offset();
historyQueueArray[historyIndex]:=TBitmap.Create;
historyQueueArray[historyIndex].Assign(bmp);
end;
end;
procedure myHistory.Clean;
var i:Integer;
begin
{ for i:=0 to hSize do begin
historyQueueArray[i].Free;
historyQueueArray[i].Destroy;
end; }
end;
constructor myHistory.Create(Size:Integer);
begin
hSize:=Size;
SetLength(historyQueueArray, hSize);
historyIndex:=-1;
end;
function myHistory.isEmpty: boolean;
begin
Result:=(historyIndex = -1);
end;
function myHistory.isFull: boolean;
begin
Result:=(historyIndex = hSize);
end;
procedure myHistory.Offset; {to handle overflow}
var i:integer;
begin
//historyQueueArray[0]:=nil;
for i:=0 to hSize-1 do begin
historyQueueArray[i]:=TBitmap.Create;
historyQueueArray[i].Assign(historyQueueArray[i+1]);
end;
end;
function myHistory.Pop: TBitmap;
var
popBmp:TBitmap;
begin
popBmp:= TBitmap.Create;
popBmp.Assign(historyQueueArray[historyIndex]);
Dec(historyIndex);
Result:=popBmp;
end;
function myHistory.getLast: TBitmap; {this function I use when I need refresh the cnvas when I draw ellipse or rect, to get rid of traces and safe previous changes of the picture}
var
tBmp:TBitmap;
begin
tBmp:= TBitmap.Create;
tBmp.Assign(historyQueueArray[historyIndex]);
Result:=tBmp;
end;
end.
And thats how I use it
procedure TMainForm.FormCreate(Sender: TObject);
var
cleanBmp:TBitmap;
begin
{...}
doneRedo:=false;
redomode:=false; undomode:=false;
//init arrays
picHistory:=myHistory.Create(10); //FOR UNDO
tempHistory:=myHistory.Create(10); //FOR REDO
cleanbmp:=TBitmap.Create;
cleanbmp.Assign(imgMain.Picture.Bitmap);
picHistory.Push(cleanbmp);
cleanbmp.Free;
{...}
end;
procedure TMainForm.btnUndoClick(Sender: TObject);
var redBmp:TBitmap;
begin
undoMode:=true;
//if there were some changes
if(not picHistory.isEmpty) then begin
redBmp:=TBitmap.Create;
redBmp.Assign(picHistory.getLast);
//clean canvas
imgMain.Picture.Bitmap:=nil;
//get what was there before
imgMain.Canvas.Draw(0,0, picHistory.Pop);
//and in case if we will not make any changes after UNDO(clicked one or more times)
//and call REDO then
tempHistory.Push(redBmp);//we save what were on canvas before UNDOand push it to redo history
redBmp.Free;
end;
end;
procedure TMainForm.btnRedoClick(Sender: TObject);
var undBmp:TBitmap;
begin
redoMode:=true;
if(not tempHistory.isEmpty) then begin
doneRedo:=True;
undBmp:=TBitmap.Create;
undBmp.Assign(tempHistory.getLast);
imgMain.Picture.Bitmap:=nil;
MainForm.imgMain.Canvas.Draw(0,0, tempHistory.Pop);
//same history (like with UNDO implementation) here but reverse
picHistory.Push(undBmp);
undBmp.Free;
end;
end;
{...}
procedure TMainForm.imgMainMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var bmp:TBitmap;
begin
//if mouse were down and then it's up this means we drew something
//and must save changes into history to be able to make UNDO
{...}
bmp:=TBitmap.Create;
try
bmp.Assign(imgMain.Picture.Bitmap);
picHistory.Push(bmp);
//if there are some changes added after redo then we clean redo history
if (doneRedo) then begin
tempHistory.Clean;
doneRedo:=false;
end;
finally
bmp.Free;
//sor of refresh
imgMain.Canvas.Draw(0,0, picHistory.getLast);
end;
{...}
But the problem is it works not way I expected. an example:
If I push undo button once - nothing happens. On twice - it does what it should at once.
And if I drew an ellipse, then click undo once and start draw new one - last drawn ellipse just dissaperas!
Here's the elipse draw method in case if it could be helpful to find out the problem
procedure TMainForm.ellipseDraw(X, Y: Integer);
begin
imgMain.Canvas.Pen.Color:=useColor;
imgMain.Canvas.Brush.Color:=scndColor;
imgMain.Canvas.Pen.Width:=size;
if(mouseIsDown) then begin
imgMain.Canvas.Draw(0,0, picHistory.getLast); //there gonna be no bizzare traces from figures
imgMain.Canvas.Ellipse(dX, dY, X,Y);
end;
end;

Answer
If I push undo button once - nothing happens. On twice - it does what it should at once.
That is indeed exactly what your code does:
In imgMainMouseUp you add the current picture to the undo list, and
In btnUndoClick you retrieve the last bitmap from the undo list, which is the same as currently seen on the Image.
The solution - to this specific question - is to add the previous bitmap to the undo list instead of the current one.
Bonus
And to address David's comment concerning the leaking, your implementation leaks Bitmaps because:
The routines Pop and getLast return a newly local created Bitmap. This places the responsibility for its destruction on the caller ot the routines. Your MainForm code does not destroy those Bitmaps, thus they are memory leaks. The solution is to simply return the item in the array, instead of creating a new Bitmap.
In the Offset routine, you again create new Bitmaps and leak all previous ones. Just assign Queue[I] to Queue[I + 1].
In the Push method, you forget to free the last item.
The class does not have a destructor, which again places the responsibility for the destruction of all Bitmaps on the user of the object with the need to call Clean, which it does not. The solution is to add a destructor to your object which calls Clean.
Besides these leaks, there are more problems with your code. Here some fixes and tips:
Since dynamic arrays are zero-based, your isFull routine does not return True when it should. It should be implemented as Result := historyIndex = hSize - 1;
Your array is not a queue (FIFO), but a stack (LIFO).
Your Pop routine does not check for an empty list.
Altogether, your history class could better look like:
uses
SysUtils, Graphics;
type
TBitmapHistory = class(TObject)
private
FIndex: Integer;
FStack: array of TBitmap;
procedure Offset;
public
procedure Clear;
function Count: Integer;
constructor Create(ACount: Integer);
destructor Destroy; override;
function Empty: Boolean;
function Full: Boolean;
function Last: TBitmap;
function Pop: TBitmap;
procedure Push(ABitmap: TBitmap);
end;
implementation
{ TBitmapHistory }
procedure TBitmapHistory.Clear;
var
I: Integer;
begin
for I := 0 to Count - 1 do
FreeAndNil(FStack[I]);
FIndex := -1;
end;
function TBitmapHistory.Count: Integer;
begin
Result := Length(FStack);
end;
constructor TBitmapHistory.Create(ACount: Integer);
begin
inherited Create;
SetLength(FStack, ACount);
FIndex := -1;
end;
destructor TBitmapHistory.Destroy;
begin
Clear;
inherited Destroy;
end;
function TBitmapHistory.Empty: Boolean;
begin
Result := FIndex = -1;
end;
function TBitmapHistory.Full: Boolean;
begin
Result := FIndex = Count - 1;
end;
function TBitmapHistory.Last: TBitmap;
begin
if Empty then
Result := nil
else
Result := FStack[FIndex];
end;
procedure TBitmapHistory.Offset;
begin
FStack[0].Free;
Move(FStack[1], FStack[0], (Count - 1) * SizeOf(TBitmap));
end;
function TBitmapHistory.Pop: TBitmap;
begin
if not Empty then
begin
Result := Last;
Dec(FIndex);
end;
end;
procedure TBitmapHistory.Push(ABitmap: TBitmap);
begin
if Full then
Offset
else
Inc(FIndex);
FStack[Findex].Free;
FStack[FIndex] := TBitmap.Create;
FStack[Findex].Assign(ABitmap);
end;
Remarks:
There also exists a specialized class TObjectStack for this in the Contnrs unit which you could override/exploit.
There are also concerns with your MainForm code, but I politely leave that up to you to fix.

Related

Delphi: how to dynamically change the type of a class if just VMT differs? [duplicate]

My Question is similar to the idea here: Replacing a component class in delphi.
But I need to change a specific component(s) class on demand.
Here is some pseudo demo code:
unit Unit1;
TForm1 = class(TForm)
ImageList1: TImageList;
ImageList2: TImageList;
private
ImageList3: TImageList;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ImageList3 := TImageList.Create(Self);
// all instances of TImageList run as usual
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Unit2.MakeSuperImageList(ImageList2);
Unit2.MakeSuperImageList(ImageList3);
// from now on ONLY ImageList2 and ImageList3 are TSuperImageList
// ImageList1 is unchanged
end;
unit Unit2;
type
TSuperImageList = class(Controls.TImageList)
protected
procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True); override;
end;
procedure TSuperImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True);
var
Icon: TIcon;
begin
Icon := TIcon.Create;
try
Self.GetIcon(Index, Icon);
Canvas.Draw(X, Y, Icon);
finally
Icon.Free;
end;
end;
procedure MakeSuperImageList(ImageList: TImageList);
begin
// TImageList -> TSuperImageList
end;
Note: Just to be clear, I want to change some instances, but not all, so interposer class will not do.
This is easier as thought (thanks to Hallvard's Blog - Hack#14: Changing the class of an object at run-time):
procedure PatchInstanceClass(Instance: TObject; NewClass: TClass);
type
PClass = ^TClass;
begin
if Assigned(Instance) and Assigned(NewClass)
and NewClass.InheritsFrom(Instance.ClassType)
and (NewClass.InstanceSize = Instance.InstanceSize) then
begin
PClass(Instance)^ := NewClass;
end;
end;
type
TMyButton = class(TButton)
public
procedure Click; override;
end;
procedure TMyButton.Click;
begin
ShowMessage('Click!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PatchInstanceClass(Button1, TMyButton);
end;
Executive summary: Use an interposer class with runtime switching of behaviour.
Although #kobik is using Delphi 5 and cannot do what I describe below, this answers fleshes out the supported way to change the VMT of an instance using TVirtualMethodInterceptor. Mason's comments inspired me to write this.
procedure MakeSuperImageList(ImageList: TImageList);
var
vmi: TVirtualMethodInterceptor;
begin
vmi := TVirtualMethodInterceptor.Create(ImageList.ClassType);
try
vmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue)
var
Icon: TIcon;
Canvas: TCanvas;
Index: Integer;
X, Y: Integer;
begin
if Method.Name<>'DoDraw' then
exit;
DoInvoke := False;//don't call TImageList.DoDraw
Index := Args[0].AsInteger;
Canvas := Args[1].AsType<TCanvas>;
X := Args[2].AsInteger;
Y := Args[3].AsInteger;
Icon := TIcon.Create;
try
ImageList.GetIcon(Index, Icon);
Canvas.Draw(X, Y, Icon);
finally
Icon.Free;
end;
end;
vmi.Proxify(ImageList);
finally
vmi.Free;
end;
end;
I've only compiled this in my head so it will no doubt need debugging. Something tells me that capturing ImageList might not work, in which case you would need to write Instance as TImageList.
Unless you use a VMT modifying based solution, you will have to create new instances (as per Mason's suggestion). And this means that you will also have to modify all references to the image list instances at the same time that you create the new instances. In my view that rules out any proposed solution based on instantiating replacement objects.
So, my conclusion is that to implement your proposed solution in full generality, you need runtime VMT modification. And if you don't have modern Delphi that provides such facilities in a supported way, you will need to hack the VMT.
Now, modifying the VMT, even with virtual method interceptors, is rather distasteful, in my view. I think you are probably going about this the wrong way. I suggest that you use an interposer class (or some other sub-classing technique) and switch behaviour at runtime with a property of the sub-class.
type
TImageList = class(ImgList.TImageList)
private
FIsSuper: Boolean;
protected
procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True); override;
public
property IsSuper: Boolean read FIsSuper write FIsSuper;
end;
TImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True);
var
Icon: TIcon;
begin
if IsSuper then
begin
Icon := TIcon.Create;
try
Self.GetIcon(Index, Icon);
Canvas.Draw(X, Y, Icon);
finally
Icon.Free;
end;
end
else
inherited;
end;
....
procedure TForm1.Button1Click(Sender: TObject);
begin
ImageList2.IsSuper := True;
ImageList3.IsSuper := True;
end;
There's no automatic way to do that, but you could try something like this:
procedure MakeSuperImageList(var ImageList: TImageList);
var
new: TImageList;
begin
if ImageList is TSuperImageList then
Exit;
new := TSuperImageList.Create(ImageList.Owner);
new.Assign(ImageList);
ImageList.Free;
ImageList := new;
end;
Depending on how Assign is implemented, it may not quite work as expected, but you can override Assign or AssignTo on TSuperImageList to get the desired behavior.

Get a list of all TStrings properties

I'm trying to find all Properties with a TStrings descendant type on an Object.
Here is what I've tried sofar:
Place a Memo and a Chart on a form and then this code.
procedure TForm1.FormCreate(Sender: TObject);
var
aObject: TObject;
begin
for aObject in GetItemsObjects(Chart1) do
Memo1.Lines.Add(aObject.ClassName);
end;
class function TForm1.GetItemsObjects(aObject: TObject): TArray<TObject>;
var
RttiProperty: TRttiProperty;
RttiType: TRttiType;
ResultList: TList<TObject>;
PropertyValue: TValue;
PropertyObject: TObject;
s: String;
begin
ResultList := TList<TObject>.Create;
try
RttiType := RttiContext.GetType(aObject.ClassType);
for RttiProperty in RttiType.GetProperties do
begin
PropertyValue := RttiProperty.GetValue(aObject);
if (not PropertyValue.IsObject) or (PropertyValue.IsEmpty) then
continue;
try
PropertyObject := PropertyValue.AsObject;
s := PropertyObject.ClassName;
if (PropertyObject is TStrings) then
ResultList.Add(PropertyObject)
else
ResultList.AddRange(GetItemsObjects(PropertyObject));
except
end;
end;
finally
Result := ResultList.ToArray;
ResultList.Free;
end;
end;
The problem is that I get an stack overflow. Even though I've tried to stop the recursion with this code:
if (PropertyObject is TStrings) then
ResultList.Add(PropertyObject)
else
ResultList.AddRange(GetItemsObjects(PropertyObject));
Your code is causing a stack overflow because you are recursively calling GetItemsObjects which also scans properties like Parent from TControl.
If you really want to recursively do a deep scan of TStrings properties then you need to make sure to not revisit the same objects again - keep track of them with a list or something.

How to hide TActionMainMenuBar images

I have TActionMainMenuBar placed on the form, which looks like this:
Now, it looks perfectly fine except that blank gap on the left where images should go. Since I don't have need to draw images in the menu, how can I hide that gap completely? Haven't been able to find any properties which I can use to hide this, and Google queries returned no results on the topic.
Below sample tries to demonstrate what it would take to use your own menu style. It just tries to gain the space from the unused images but you can override any aspect of the drawing, see 'xpactnctrls.pas' for possible implementation.
type
TBarStyle = class(TXPStyleActionBars)
public
function GetControlClass(ActionBar: TCustomActionBar;
AnItem: TActionClientItem): TCustomActionControlClass; override;
end;
TMenuStyle = class(TXPStyleMenuItem)
protected
procedure CalcLayout; override;
public
procedure CalcBounds; override;
end;
var
BarStyle: TBarStyle;
function TBarStyle.GetControlClass(ActionBar: TCustomActionBar;
AnItem: TActionClientItem): TCustomActionControlClass;
begin
Result := inherited GetControlClass(ActionBar, AnItem);
if ActionBar is TCustomActionPopupMenu then
Result := TMenuStyle;
end;
procedure TMenuStyle.CalcLayout;
begin
inherited;
GlyphPos := Point(-16, GlyphPos.Y);
end;
procedure TMenuStyle.CalcBounds;
var
R: TRect;
begin
inherited;
R := TextBounds;
OffsetRect(R, -16, 0);
TextBounds := R;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ActionMainMenuBar1.ActionManager.Style := BarStyle;
end;
initialization
BarStyle := TBarStyle.Create;
RegisterActnBarStyle(BarStyle);
finalization
UnregisterActnBarStyle(BarStyle);
BArStyle.Free;

Changing component class at run-time on demand

My Question is similar to the idea here: Replacing a component class in delphi.
But I need to change a specific component(s) class on demand.
Here is some pseudo demo code:
unit Unit1;
TForm1 = class(TForm)
ImageList1: TImageList;
ImageList2: TImageList;
private
ImageList3: TImageList;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ImageList3 := TImageList.Create(Self);
// all instances of TImageList run as usual
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Unit2.MakeSuperImageList(ImageList2);
Unit2.MakeSuperImageList(ImageList3);
// from now on ONLY ImageList2 and ImageList3 are TSuperImageList
// ImageList1 is unchanged
end;
unit Unit2;
type
TSuperImageList = class(Controls.TImageList)
protected
procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True); override;
end;
procedure TSuperImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True);
var
Icon: TIcon;
begin
Icon := TIcon.Create;
try
Self.GetIcon(Index, Icon);
Canvas.Draw(X, Y, Icon);
finally
Icon.Free;
end;
end;
procedure MakeSuperImageList(ImageList: TImageList);
begin
// TImageList -> TSuperImageList
end;
Note: Just to be clear, I want to change some instances, but not all, so interposer class will not do.
This is easier as thought (thanks to Hallvard's Blog - Hack#14: Changing the class of an object at run-time):
procedure PatchInstanceClass(Instance: TObject; NewClass: TClass);
type
PClass = ^TClass;
begin
if Assigned(Instance) and Assigned(NewClass)
and NewClass.InheritsFrom(Instance.ClassType)
and (NewClass.InstanceSize = Instance.InstanceSize) then
begin
PClass(Instance)^ := NewClass;
end;
end;
type
TMyButton = class(TButton)
public
procedure Click; override;
end;
procedure TMyButton.Click;
begin
ShowMessage('Click!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PatchInstanceClass(Button1, TMyButton);
end;
Executive summary: Use an interposer class with runtime switching of behaviour.
Although #kobik is using Delphi 5 and cannot do what I describe below, this answers fleshes out the supported way to change the VMT of an instance using TVirtualMethodInterceptor. Mason's comments inspired me to write this.
procedure MakeSuperImageList(ImageList: TImageList);
var
vmi: TVirtualMethodInterceptor;
begin
vmi := TVirtualMethodInterceptor.Create(ImageList.ClassType);
try
vmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue)
var
Icon: TIcon;
Canvas: TCanvas;
Index: Integer;
X, Y: Integer;
begin
if Method.Name<>'DoDraw' then
exit;
DoInvoke := False;//don't call TImageList.DoDraw
Index := Args[0].AsInteger;
Canvas := Args[1].AsType<TCanvas>;
X := Args[2].AsInteger;
Y := Args[3].AsInteger;
Icon := TIcon.Create;
try
ImageList.GetIcon(Index, Icon);
Canvas.Draw(X, Y, Icon);
finally
Icon.Free;
end;
end;
vmi.Proxify(ImageList);
finally
vmi.Free;
end;
end;
I've only compiled this in my head so it will no doubt need debugging. Something tells me that capturing ImageList might not work, in which case you would need to write Instance as TImageList.
Unless you use a VMT modifying based solution, you will have to create new instances (as per Mason's suggestion). And this means that you will also have to modify all references to the image list instances at the same time that you create the new instances. In my view that rules out any proposed solution based on instantiating replacement objects.
So, my conclusion is that to implement your proposed solution in full generality, you need runtime VMT modification. And if you don't have modern Delphi that provides such facilities in a supported way, you will need to hack the VMT.
Now, modifying the VMT, even with virtual method interceptors, is rather distasteful, in my view. I think you are probably going about this the wrong way. I suggest that you use an interposer class (or some other sub-classing technique) and switch behaviour at runtime with a property of the sub-class.
type
TImageList = class(ImgList.TImageList)
private
FIsSuper: Boolean;
protected
procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True); override;
public
property IsSuper: Boolean read FIsSuper write FIsSuper;
end;
TImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
Style: Cardinal; Enabled: Boolean = True);
var
Icon: TIcon;
begin
if IsSuper then
begin
Icon := TIcon.Create;
try
Self.GetIcon(Index, Icon);
Canvas.Draw(X, Y, Icon);
finally
Icon.Free;
end;
end
else
inherited;
end;
....
procedure TForm1.Button1Click(Sender: TObject);
begin
ImageList2.IsSuper := True;
ImageList3.IsSuper := True;
end;
There's no automatic way to do that, but you could try something like this:
procedure MakeSuperImageList(var ImageList: TImageList);
var
new: TImageList;
begin
if ImageList is TSuperImageList then
Exit;
new := TSuperImageList.Create(ImageList.Owner);
new.Assign(ImageList);
ImageList.Free;
ImageList := new;
end;
Depending on how Assign is implemented, it may not quite work as expected, but you can override Assign or AssignTo on TSuperImageList to get the desired behavior.

Delphi: How to make cells' texts in TStringGrid center aligned?

It seems something obvious to have. I want the texts to be in the center of the cells, but for some reason I can't find it in properties. How can I do this?
There's no property to center the text in TStringGrid, but you can do that at DrawCell event as:
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
S: string;
SavedAlign: word;
begin
if ACol = 1 then begin // ACol is zero based
S := StringGrid1.Cells[ACol, ARow]; // cell contents
SavedAlign := SetTextAlign(StringGrid1.Canvas.Handle, TA_CENTER);
StringGrid1.Canvas.TextRect(Rect,
Rect.Left + (Rect.Right - Rect.Left) div 2, Rect.Top + 2, S);
SetTextAlign(StringGrid1.Canvas.Handle, SavedAlign);
end;
end;
The code I posted from here
UPDATE:
to center text while writing in the cell, add this code to GetEditText Event:
procedure TForm1.StringGrid1GetEditText(Sender: TObject; ACol, ARow: Integer;
var Value: string);
var
S : String;
I: Integer;
IE : TInplaceEdit ;
begin
for I := 0 to StringGrid1.ControlCount - 1 do
if StringGrid1.Controls[i].ClassName = 'TInplaceEdit' then
begin
IE := TInplaceEdit(StringGrid1.Controls[i]);
ie.Alignment := taCenter
end;
end;
This one is a much better solution that the others and on them there was a mistype on procedures TStringGrid.SetCellsAlignment and TStringGrid.SetCellsAlignment the (-1 < Index) compare was correct, but then and else parts were swapped... The correct version (this one) will show that when index is bigger than -1 it will overwrite value stored else it will add a new entry, the others will do just the oposite bringing a list out of index message, thanks for detecting such.
I have also make able to be all in another separated unit, so here it is (hope now it is correct and thanks for detecting such mistypes):
unit AlignedTStringGrid;
interface
uses Windows,SysUtils,Classes,Grids;
type
TStringGrid=class(Grids.TStringGrid)
private
FCellsAlignment:TStringList;
FColsDefaultAlignment:TStringList;
function GetCellsAlignment(ACol,ARow:Integer):TAlignment;
procedure SetCellsAlignment(ACol,ARow:Integer;const Alignment:TAlignment);
function GetColsDefaultAlignment(ACol:Integer):TAlignment;
procedure SetColsDefaultAlignment(ACol:Integer;const Alignment:TAlignment);
protected
procedure DrawCell(ACol,ARow:Longint;ARect:TRect;AState:TGridDrawState);override;
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
property CellsAlignment[ACol,ARow:Integer]:TAlignment read GetCellsAlignment write SetCellsAlignment;
property ColsDefaultAlignment[ACol:Integer]:TAlignment read GetColsDefaultAlignment write SetColsDefaultAlignment;
end;
implementation
constructor TStringGrid.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FCellsAlignment:=TStringList.Create;
FCellsAlignment.CaseSensitive:=True;
FCellsAlignment.Sorted:=True;
FCellsAlignment.Duplicates:=dupIgnore;
FColsDefaultAlignment:=TStringList.Create;
FColsDefaultAlignment.CaseSensitive:=True;
FColsDefaultAlignment.Sorted:=True;
FColsDefaultAlignment.Duplicates:=dupIgnore;
end;
destructor TStringGrid.Destroy;
begin
FCellsAlignment.Free;
FColsDefaultAlignment.Free;
inherited Destroy;
end;
procedure TStringGrid.SetCellsAlignment(ACol,ARow: Integer; const Alignment: TAlignment);
var
Index:Integer;
begin
if (-1 < Index) then begin
FCellsAlignment.Objects[Index]:= TObject(Alignment);
end else begin
FCellsAlignment.AddObject(IntToStr(ACol) + '-' + IntToStr(ARow), TObject(Alignment));
end;
end;
function TStringGrid.GetCellsAlignment(ACol,ARow: Integer): TAlignment;
var
Index:Integer;
begin
Index:= FCellsAlignment.IndexOf(IntToStr(ACol)+'-'+IntToStr(ARow));
if (-1 < Index) then begin
GetCellsAlignment:= TAlignment(FCellsAlignment.Objects[Index]);
end else begin
GetCellsAlignment:= ColsDefaultAlignment[ACol];
end;
end;
procedure TStringGrid.SetColsDefaultAlignment(ACol: Integer; const Alignment: TAlignment);
var
Index:Integer;
begin
Index:= FColsDefaultAlignment.IndexOf(IntToStr(ACol));
if (-1 < Index) then begin
FColsDefaultAlignment.Objects[Index]:= TObject(Alignment);
end else begin
FColsDefaultAlignment.AddObject(IntToStr(ACol), TObject(Alignment));
end;
end;
function TStringGrid.GetColsDefaultAlignment(ACol:Integer):TAlignment;
var
Index:Integer;
begin
Index:= FColsDefaultAlignment.IndexOf(IntToStr(ACol));
if (-1 < Index) then begin
GetColsDefaultAlignment:= TAlignment(FColsDefaultAlignment.Objects[Index]);
end else begin
GetColsDefaultAlignment:=taLeftJustify;
end;
end;
procedure TStringGrid.DrawCell(ACol,ARow:Longint;ARect:TRect;AState:TGridDrawState);
var
Old_DefaultDrawing:Boolean;
begin
if DefaultDrawing then begin
case CellsAlignment[ACol,ARow] of
taLeftJustify: begin
Canvas.TextRect(ARect,ARect.Left+2,ARect.Top+2,Cells[ACol,ARow]);
end;
taRightJustify: begin
Canvas.TextRect(ARect,ARect.Right -2 -Canvas.TextWidth(Cells[ACol,ARow]), ARect.Top+2,Cells[ACol,ARow]);
end;
taCenter: begin
Canvas.TextRect(ARect,(ARect.Left+ARect.Right-Canvas.TextWidth(Cells[ACol,ARow]))div 2,ARect.Top+2,Cells[ACol,ARow]);
end;
end;
end;
Old_DefaultDrawing:= DefaultDrawing;
DefaultDrawing:=False;
inherited DrawCell(ACol,ARow,ARect,AState);
DefaultDrawing:= Old_DefaultDrawing;
end;
end.
This is a whole unit, save it to a file called AlignedTStringGrid.pas.
Then on any form you have a TStringGrid add ,AlignedTStringGrid at the end of the interface uses clause.
Note: The same can be done for rows, but for now I do not know how to mix both (cols and rows) because of how to select priority, if anyone is very interested on it let me know.
P.D.: The same idea is possible to be done for TEdit, just search on stackoverflow.com for TEdit.CreateParams or read post How to set textalignment in TEdit control

Resources