KOMPONENT KODU
KULLANIMI
unit thsStringGrid;
interface
uses
System.SysUtils
, System.Classes
, System.Types
, System.Generics.Collections
, Vcl.Graphics
, Vcl.Controls
, Vcl.Grids
, Winapi.Messages
// , DesignIntf
// , DesignEditors
;
type
TThsStringGrid = class;
TStyleValue = (svFont, svColor, svTextAlign, svBorder);
TStyleValues = set of TStyleValue;
TThsCellDataType = (ctString, ctInteger, ctDouble, ctDate, ctTime, ctDateTime, ctBcd);
TThsRowType = (rtHeader, rtFooter, rtRow, rtTitle, rtSubTitle);
TThsBorder = class(TPersistent)
private
FEnable: Boolean;
FColor: TColor;
FWidth: Integer;
function GetColor: TColor;
function GetEnable: Boolean;
function GetWidth: Integer;
procedure SetColor(const Value: TColor);
procedure SetEnable(const Value: Boolean);
procedure SetWidth(const Value: Integer);
published
property Enable: Boolean read GetEnable write SetEnable;
property Color: TColor read GetColor write SetColor;
property Width: Integer read GetWidth write SetWidth;
end;
TThsCellBorder = class(TPersistent)
private
FLeft: TThsBorder;
FRight: TThsBorder;
FTop: TThsBorder;
FBottom: TThsBorder;
function GetBottom: TThsBorder;
function GetLeft: TThsBorder;
function GetRight: TThsBorder;
function GetTop: TThsBorder;
procedure SetBottom(const Value: TThsBorder);
procedure SetLeft(const Value: TThsBorder);
procedure SetRight(const Value: TThsBorder);
procedure SetTop(const Value: TThsBorder);
public
constructor Create;
destructor Destroy; override;
published
property Left: TThsBorder read GetLeft write SetLeft;
property Right: TThsBorder read GetRight write SetRight;
property Top: TThsBorder read GetTop write SetTop;
property Bottom: TThsBorder read GetBottom write SetBottom;
end;
TThsStyle = class(TPersistent)
private
FFont: TFont;
FColor: TColor;
FTextAlign: TAlignment;
FBorder: TThsCellBorder;
FBorderActive: Boolean;
FStyleName: string;
published
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
property Font: TFont read FFont write FFont;
property Color: TColor read FColor write FColor;
property TextAlign: TAlignment read FTextAlign write FTextAlign;
property Border: TThsCellBorder read FBorder write FBorder;
property BorderActive: Boolean read FBorderActive write FBorderActive;
property StyleName: string read FStyleName write FStyleName;
end;
TThsStyledCell = class(TPersistent)
private
FRowNo: Integer;
FColNo: Integer;
FStyle: TThsStyle;
function GetColNo: Integer;
function GetRowNo: Integer;
function GetStyle: TThsStyle;
procedure SetColNo(const Value: Integer);
procedure SetRowNo(const Value: Integer);
procedure SetStyle(const Value: TThsStyle);
public
destructor Destroy; override;
published
property RowNo: Integer read GetRowNo write SetRowNo;
property ColNo: Integer read GetColNo write SetColNo;
property Style: TThsStyle read GetStyle write SetStyle;
end;
TThsStyledRow = class(TPersistent)
private
FRowStartNo: Integer;
FRowEndNo: Integer;
FStyle: TThsStyle;
FRowType: TThsRowType;
function GetRowStartNo: Integer;
function GetRowEndNo: Integer;
function GetStyle: TThsStyle;
procedure SetRowStartNo(const Value: Integer);
procedure SetRowEndNo(const Value: Integer);
procedure SetStyle(const Value: TThsStyle);
function GetRowType: TThsRowType;
procedure SetRowType(const Value: TThsRowType);
public
constructor Create();
destructor Destroy; override;
published
property RowStartNo: Integer read GetRowStartNo write SetRowStartNo;
property RowEndNo: Integer read GetRowEndNo write SetRowEndNo;
property Style: TThsStyle read GetStyle write SetStyle;
property RowType: TThsRowType read GetRowType write SetRowType;
end;
TThsStyledCol = class(TPersistent)
private
FColNo: Integer;
FStyle: TThsStyle;
function GetColNo: Integer;
function GetStyle: TThsStyle;
procedure SetColNo(const Value: Integer);
procedure SetStyle(const Value: TThsStyle);
public
constructor Create();
destructor Destroy; override;
published
property ColNo: Integer read GetColNo write SetColNo;
property Style: TThsStyle read GetStyle write SetStyle;
end;
TThsStringGrid = class(TStringGrid)
private
FStyledCellItems: TObjectList<TThsStyledCell>;
FStyledRowItems: TObjectList<TThsStyledRow>;
FStyledColItems: TObjectList<TThsStyledCol>;
function GetStyledCellItems: TObjectList<TThsStyledCell>;
procedure SetStyledCellItems(const Value: TObjectList<TThsStyledCell>);
function GetStyledRowItems: TObjectList<TThsStyledRow>;
procedure SetStyledRowItems(const Value: TObjectList<TThsStyledRow>);
function GetStyledColItems: TObjectList<TThsStyledCol>;
procedure SetStyledColItems(const Value: TObjectList<TThsStyledCol>);
protected
procedure DrawCell(ACol: Integer; ARow: Integer; ARect: TRect; AState: TGridDrawState); override;
procedure ColumnMoved(FromIndex: Integer; ToIndex: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ClearAllStyle();
procedure ClearCellStyle();
procedure ClearRowStyle();
procedure ClearColStyle();
function GetStyledCellItem(Index: Integer): TThsStyledCell;
function GetStyleFromStyledCells(Index: Integer): TThsStyle;
function ExistsStyledCellItem(ARow, ACol: Integer): Integer;
property StyledCellItems: TObjectList<TThsStyledCell> read GetStyledCellItems write SetStyledCellItems;
function AddStyledCell: TThsStyledCell;
function GetStyledRowItem(Index: Integer): TThsStyledRow;
function GetStyleFromStyledRows(Index: Integer): TThsStyle;
function ExistsStyledRowItem(ARow: Integer): Integer;
property StyledRowItems: TObjectList<TThsStyledRow> read GetStyledRowItems write SetStyledRowItems;
function AddStyledRow: TThsStyledRow;
function GetStyledColItem(Index: Integer): TThsStyledCol;
function GetStyleFromStyledCols(Index: Integer): TThsStyle;
function ExistsStyledColItem(ACol: Integer): Integer;
property StyledColItems: TObjectList<TThsStyledCol> read GetStyledColItems write SetStyledColItems;
function AddStyledCol: TThsStyledCol;
end;
{
type
TThsStringGridMenu = class(TComponentEditor)
function GetVerbCount: Integer; override;
function GetVerb(index: Integer): String; override;
procedure ExecuteVerb(Index: Integer); override;
end;
}
procedure Register;
implementation
uses
Vcl.Dialogs;
procedure Register;
begin
RegisterComponents('Ths Component Set', [TThsStringGrid]);
// RegisterComponentEditor(TThsStringGrid, TThsStringGridMenu)
end;
{ TThsBorder }
function TThsBorder.GetColor: TColor;
begin
Result := FColor;
end;
function TThsBorder.GetEnable: Boolean;
begin
Result := FEnable;
end;
function TThsBorder.GetWidth: Integer;
begin
Result := FWidth;
end;
procedure TThsBorder.SetColor(const Value: TColor);
begin
FColor := Value;
end;
procedure TThsBorder.SetEnable(const Value: Boolean);
begin
FEnable := Value;
end;
procedure TThsBorder.SetWidth(const Value: Integer);
begin
FWidth := Value;
end;
{ TThsCellBorder }
constructor TThsCellBorder.Create();
begin
inherited;
FLeft := TThsBorder.Create;
FRight := TThsBorder.Create;
FTop := TThsBorder.Create;
FBottom := TThsBorder.Create;
end;
destructor TThsCellBorder.Destroy;
begin
if FLeft <> nil then
FreeAndNil(FLeft);
if FRight <> nil then
FreeAndNil(FRight);
if FTop <> nil then
FreeAndNil(FTop);
if FBottom <> nil then
FreeAndNil(FBottom);
inherited;
end;
function TThsCellBorder.GetBottom: TThsBorder;
begin
Result := FBottom;
end;
function TThsCellBorder.GetLeft: TThsBorder;
begin
Result := FLeft;
end;
function TThsCellBorder.GetRight: TThsBorder;
begin
Result := FRight;
end;
function TThsCellBorder.GetTop: TThsBorder;
begin
Result := FTop;
end;
procedure TThsCellBorder.SetBottom(const Value: TThsBorder);
begin
FBottom.Assign(Value);
end;
procedure TThsCellBorder.SetLeft(const Value: TThsBorder);
begin
FLeft.Assign(Value);
end;
procedure TThsCellBorder.SetRight(const Value: TThsBorder);
begin
FRight.AssignTo(Value);
end;
procedure TThsCellBorder.SetTop(const Value: TThsBorder);
begin
FTop.Assign(Value);
end;
{ TThsStyle }
procedure TThsStyle.Assign(Source: TPersistent);
begin
if Source is TThsStyle then
begin
Self.FFont.Color := TThsStyle(Source).Font.Color;
Self.FFont.Name := TThsStyle(Source).Font.Name;
Self.FFont.Size := TThsStyle(Source).Font.Size;
Self.FFont.Style := TThsStyle(Source).Font.Style;
Self.FColor := TThsStyle(Source).Color;
Self.FTextAlign := TThsStyle(Source).TextAlign;
Self.FBorderActive := TThsStyle(Source).BorderActive;
Self.FBorder.Left.Enable := TThsStyle(Source).Border.Left.Enable;
Self.FBorder.Left.Color := TThsStyle(Source).Border.Left.Color;
Self.FBorder.Left.Width := TThsStyle(Source).Border.Left.Width;
Self.FBorder.Right.Enable := TThsStyle(Source).Border.Right.Enable;
Self.FBorder.Right.Color := TThsStyle(Source).Border.Right.Color;
Self.FBorder.Right.Width := TThsStyle(Source).Border.Right.Width;
Self.FBorder.Top.Enable := TThsStyle(Source).Border.Top.Enable;
Self.FBorder.Top.Color := TThsStyle(Source).Border.Top.Color;
Self.FBorder.Top.Width := TThsStyle(Source).Border.Top.Width;
Self.FBorder.Bottom.Enable := TThsStyle(Source).Border.Bottom.Enable;
Self.FBorder.Bottom.Color := TThsStyle(Source).Border.Bottom.Color;
Self.FBorder.Bottom.Width := TThsStyle(Source).Border.Bottom.Width;
end
else
inherited;
end;
constructor TThsStyle.Create();
begin
FFont := TFont.Create;
FColor := clWhite;
FTextAlign := taLeftJustify;
FBorder := TThsCellBorder.Create;
FBorderActive := False;
end;
destructor TThsStyle.Destroy;
begin
if FFont <> nil then
FreeAndNil(FFont);
if FBorder <> nil then
FreeAndNil(FBorder);
inherited;
end;
{ TThsStyledCell }
destructor TThsStyledCell.Destroy;
begin
if FStyle <> nil then
FreeAndNil(FStyle);
inherited;
end;
function TThsStyledCell.GetColNo: Integer;
begin
Result := FColNo;
end;
function TThsStyledCell.GetRowNo: Integer;
begin
Result := FRowNo;
end;
function TThsStyledCell.GetStyle: TThsStyle;
begin
Result := FStyle;
end;
procedure TThsStyledCell.SetColNo(const Value: Integer);
begin
FColNo := Value;
end;
procedure TThsStyledCell.SetRowNo(const Value: Integer);
begin
FRowNo := Value;
end;
procedure TThsStyledCell.SetStyle(const Value: TThsStyle);
begin
FStyle := Value;
end;
{ TThsStyledCol }
constructor TThsStyledCol.Create();
begin
inherited;
end;
destructor TThsStyledCol.Destroy;
begin
if FStyle <> nil then
FreeAndNil(FStyle);
inherited;
end;
function TThsStyledCol.GetColNo: Integer;
begin
Result := FColNo;
end;
function TThsStyledCol.GetStyle: TThsStyle;
begin
Result := FStyle;
end;
procedure TThsStyledCol.SetColNo(const Value: Integer);
begin
FColNo := Value;
end;
procedure TThsStyledCol.SetStyle(const Value: TThsStyle);
begin
FStyle := Value;
end;
{ TThsStyledRow }
constructor TThsStyledRow.Create();
begin
inherited;
FRowType := rtRow;
end;
function TThsStyledRow.GetRowStartNo: Integer;
begin
Result := FRowStartNo;
end;
destructor TThsStyledRow.Destroy;
begin
if FStyle <> nil then
FreeAndNil(FStyle);
inherited;
end;
function TThsStyledRow.GetRowEndNo: Integer;
begin
Result := FRowEndNo;
end;
function TThsStyledRow.GetStyle: TThsStyle;
begin
Result := FStyle;
end;
function TThsStyledRow.GetRowType: TThsRowType;
begin
Result := FRowType;
end;
procedure TThsStyledRow.SetRowStartNo(const Value: Integer);
begin
FRowStartNo := Value;
end;
procedure TThsStyledRow.SetRowEndNo(const Value: Integer);
begin
FRowEndNo := Value;
end;
procedure TThsStyledRow.SetStyle(const Value: TThsStyle);
begin
FStyle := Value;
end;
procedure TThsStyledRow.SetRowType(const Value: TThsRowType);
begin
FRowType := Value;
end;
{ TThsStringGrid }
function TThsStringGrid.AddStyledCell: TThsStyledCell;
begin
Result := TThsStyledCell.Create;
FStyledCellItems.Add(Result);
end;
function TThsStringGrid.AddStyledCol: TThsStyledCol;
begin
Result := TThsStyledCol.Create;
FStyledColItems.Add(Result);
end;
function TThsStringGrid.AddStyledRow: TThsStyledRow;
begin
Result := TThsStyledRow.Create;
FStyledRowItems.Add(Result);
end;
procedure TThsStringGrid.ClearAllStyle;
var
n1: Integer;
begin
Perform(WM_SETREDRAW, 0, 0);
try
for n1 := StyledCellItems.Count-1 downto 0 do
StyledCellItems.Delete(n1);
for n1 := StyledRowItems.Count-1 downto 0 do
StyledRowItems.Delete(n1);
for n1 := StyledColItems.Count-1 downto 0 do
StyledColItems.Delete(n1);
finally
Perform(WM_SETREDRAW, 1, 0);
Invalidate;
end;
end;
procedure TThsStringGrid.ClearCellStyle;
var
n1: Integer;
begin
Perform(WM_SETREDRAW, 0, 0);
try
for n1 := StyledCellItems.Count-1 downto 0 do
StyledCellItems.Delete(n1);
finally
Perform(WM_SETREDRAW, 1, 0);
Invalidate;
end;
end;
procedure TThsStringGrid.ClearColStyle;
var
n1: Integer;
begin
Perform(WM_SETREDRAW, 0, 0);
try
for n1 := StyledColItems.Count-1 downto 0 do
StyledColItems.Delete(n1);
finally
Perform(WM_SETREDRAW, 1, 0);
Invalidate;
end;
end;
procedure TThsStringGrid.ClearRowStyle;
var
n1: Integer;
begin
Perform(WM_SETREDRAW, 0, 0);
try
for n1 := StyledRowItems.Count-1 downto 0 do
StyledRowItems.Delete(n1);
finally
Perform(WM_SETREDRAW, 1, 0);
Invalidate;
end;
end;
procedure TThsStringGrid.ColumnMoved(FromIndex, ToIndex: Integer);
var
n1, Len: Integer;
IsFromStyled, IsToStyled: Boolean;
LFromStyleIdx, LToStyleIdx, LFromCol, LToCol: Integer;
begin
inherited;
LFromStyleIdx := -1;
LToStyleIdx := -1;
Len := FStyledColItems.Count-1;
for n1 := 0 to Len do
if (FStyledColItems.Items[n1].ColNo = FromIndex) then
begin
LFromStyleIdx := n1;
IsFromStyled := True;
end;
for n1 := 0 to Len do
if (FStyledColItems.Items[n1].ColNo = ToIndex) then
begin
LToStyleIdx := n1;
IsToStyled := True;
end;
if IsFromStyled and not IsToStyled then
FStyledColItems.Items[LFromStyleIdx].ColNo := ToIndex;
if not IsFromStyled and IsToStyled then
FStyledColItems.Items[LToStyleIdx].ColNo := FromIndex;
if IsFromStyled and IsToStyled then
begin
FStyledColItems.Items[LFromStyleIdx].ColNo := ToIndex;
FStyledColItems.Items[LToStyleIdx].ColNo := FromIndex;
end;
Self.Invalidate;
end;
constructor TThsStringGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Self.DoubleBuffered := True;
FStyledCellItems := TObjectList<TThsStyledCell>.Create;
FStyledRowItems := TObjectList<TThsStyledRow>.Create;
FStyledColItems := TObjectList<TThsStyledCol>.Create;
end;
destructor TThsStringGrid.Destroy;
begin
FStyledCellItems.Free;
FStyledRowItems.Free;
FStyledColItems.Free;
inherited;
end;
procedure TThsStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState);
var
vTextWidth, vTextHeight, vTop, vLeft: Integer;
vValue: string;
AStyle: TThsStyle;
LStyleIdx: Integer;
LLineL, LLineR, LLineT, LLineB: Integer;
begin
inherited;
if not (csDesigning in Self.ComponentState) then
begin
Rows[ARow].BeginUpdate;
Cols[ACol].BeginUpdate;
try
vLeft := ARect.Left;
//col style
LStyleIdx := ExistsStyledColItem(ACol);
if LStyleIdx > -1 then
begin
LLineL := 0;
LLineR := 0;
LLineT := 0;
LLineB := 0;
AStyle := GetStyleFromStyledCols(LStyleIdx);
if AStyle <> nil then
begin
if AStyle.BorderActive then
begin
if AStyle.Border.Left.Enable then LLineL := AStyle.FBorder.FLeft.Width;
if AStyle.Border.Right.Enable then LLineR := AStyle.Border.Right.Width;
if AStyle.Border.Top.Enable then LLineT := AStyle.Border.Top.Width;
if AStyle.Border.Bottom.Enable then LLineB := AStyle.Border.Bottom.Width;
end;
Canvas.Font := AStyle.Font;
Canvas.Brush.Color := AStyle.Color;
ARect.Left := ARect.Left + LLineL;
ARect.Right := ARect.Right - LLineR;
ARect.Top := ARect.Top + LLineT;
ARect.Bottom := ARect.Bottom - LLineB;
if gdSelected in AState then begin
Canvas.Brush.Color := clHighlight;
end;
Canvas.FillRect(ARect);
vValue := Cells[ACol, ARow];
vTextWidth := Canvas.TextWidth(vValue);
vTextHeight := Canvas.TextHeight(vValue);
vTop := (ARect.Height - vTextHeight) div 2;
vTop := ARect.Top + vTop;
if AStyle.TextAlign = taLeftJustify then
vLeft := ARect.Left
else if AStyle.TextAlign = taRightJustify then
vLeft := ARect.Left + ColWidths[ACol] - vTextWidth - 6
else if AStyle.TextAlign = taCenter then
vLeft := ARect.Left + (ARect.Width - vTextWidth) div 2;
Canvas.TextRect(ARect, vLeft, vTop, vValue);
if AStyle.BorderActive and not (gdSelected in AState) then
begin
if AStyle.Border.Left.Enable then begin
Canvas.Pen.Width := AStyle.Border.FLeft.Width;
Canvas.Pen.Color := AStyle.Border.FLeft.Color;
Canvas.MoveTo(ARect.Left, ARect.Top);
Canvas.LineTo(ARect.Left, ARect.Bottom);
end;
if AStyle.Border.Right.Enable then begin
Canvas.Pen.Width := AStyle.Border.Right.Width;
Canvas.Pen.Color := AStyle.Border.Right.Color;
Canvas.MoveTo(ARect.Right, ARect.Top);
Canvas.LineTo(ARect.Right, ARect.Bottom);
end;
if AStyle.Border.Top.Enable then begin
Canvas.Pen.Width := AStyle.Border.Top.Width;
Canvas.Pen.Color := AStyle.Border.Top.Color;
Canvas.MoveTo(ARect.Left, ARect.Top);
Canvas.LineTo(ARect.Right, ARect.Top);
end;
if AStyle.Border.Bottom.Enable then begin
Canvas.Pen.Width := AStyle.Border.Bottom.Width;
Canvas.Pen.Color := AStyle.Border.Bottom.Color;
Canvas.MoveTo(ARect.Left, ARect.Bottom);
Canvas.LineTo(ARect.Right, ARect.Bottom);
end;
end;
if ColWidths[ACol] < vTextWidth then
ColWidths[ACol] := vTextWidth + LLineL + LLineR;
end;
end;
//row style
LStyleIdx := ExistsStyledRowItem(ARow);
if LStyleIdx > -1 then
begin
LLineL := 0;
LLineR := 0;
LLineT := 0;
LLineB := 0;
AStyle := GetStyleFromStyledRows(LStyleIdx);
if AStyle <> nil then
begin
if AStyle.BorderActive then
begin
if AStyle.Border.Left.Enable then LLineL := AStyle.Border.Left.Width;
if AStyle.Border.Right.Enable then LLineR := AStyle.Border.Right.Width;
if AStyle.Border.Top.Enable then LLineT := AStyle.Border.Top.Width;
if AStyle.Border.Bottom.Enable then LLineB := AStyle.Border.Bottom.Width;
end;
Canvas.Font := AStyle.Font;
Canvas.Brush.Color := AStyle.Color;
ARect.Left := ARect.Left + LLineL;
ARect.Right := ARect.Right - LLineR;
ARect.Top := ARect.Top + LLineT;
ARect.Bottom := ARect.Bottom - LLineB;
if gdSelected in AState then begin
Canvas.Brush.Color := clHighlight;
end;
Canvas.FillRect(ARect);
vValue := Cells[ACol, ARow];
vTextWidth := Canvas.TextWidth(vValue);
vTextHeight := Canvas.TextHeight(vValue);
vTop := (ARect.Height - vTextHeight) div 2;
vTop := ARect.Top + vTop;
if AStyle.TextAlign = taLeftJustify then
vLeft := ARect.Left
else if AStyle.TextAlign = taRightJustify then
vLeft := ARect.Left + ColWidths[ACol] - vTextWidth - 6
else if AStyle.TextAlign = taCenter then
vLeft := ARect.Left + (ARect.Width - vTextWidth) div 2;
Canvas.TextRect(ARect, vLeft, vTop, vValue);
if AStyle.BorderActive and not (gdSelected in AState) then
begin
if AStyle.Border.Left.Enable then begin
Canvas.Pen.Width := AStyle.Border.FLeft.Width;
Canvas.Pen.Color := AStyle.Border.FLeft.Color;
Canvas.MoveTo(ARect.Left, ARect.Top);
Canvas.LineTo(ARect.Left, ARect.Bottom);
end;
if AStyle.Border.Right.Enable then begin
Canvas.Pen.Width := AStyle.Border.Right.Width;
Canvas.Pen.Color := AStyle.Border.Right.Color;
Canvas.MoveTo(ARect.Right, ARect.Top);
Canvas.LineTo(ARect.Right, ARect.Bottom);
end;
if AStyle.Border.Top.Enable then begin
Canvas.Pen.Width := AStyle.Border.Top.Width;
Canvas.Pen.Color := AStyle.Border.Top.Color;
Canvas.MoveTo(ARect.Left, ARect.Top);
Canvas.LineTo(ARect.Right, ARect.Top);
end;
if AStyle.Border.Bottom.Enable then begin
Canvas.Pen.Width := AStyle.Border.Bottom.Width;
Canvas.Pen.Color := AStyle.Border.Bottom.Color;
Canvas.MoveTo(ARect.Left, ARect.Bottom);
Canvas.LineTo(ARect.Right, ARect.Bottom);
end;
end;
if RowHeights[ARow] < vTextHeight then
RowHeights[ARow] := vTextHeight + LLineT + LLineB;
end;
end;
//cell style
LStyleIdx := ExistsStyledCellItem(ARow, ACol);
if LStyleIdx > -1 then
begin
LLineL := 0;
LLineR := 0;
LLineT := 0;
LLineB := 0;
AStyle := GetStyleFromStyledCells(LStyleIdx);
if AStyle <> nil then
begin
if AStyle.BorderActive then
begin
if AStyle.Border.Left.Enable then LLineL := AStyle.Border.Left.Width;
if AStyle.Border.Right.Enable then LLineR := AStyle.Border.Right.Width;
if AStyle.Border.Top.Enable then LLineT := AStyle.Border.Top.Width;
if AStyle.Border.Bottom.Enable then LLineB := AStyle.Border.Bottom.Width;
end;
Canvas.Font := AStyle.Font;
Canvas.Brush.Color := AStyle.Color;
ARect.Left := ARect.Left + LLineL;
ARect.Right := ARect.Right - LLineR;
ARect.Top := ARect.Top + LLineT;
ARect.Bottom := ARect.Bottom - LLineB;
if gdSelected in AState then begin
Canvas.Brush.Color := clHighlight;
end;
Canvas.FillRect(ARect);
vValue := Cells[ACol, ARow];
vTextWidth := Canvas.TextWidth(vValue);
vTextHeight := Canvas.TextHeight(vValue);
vTop := (ARect.Height - vTextHeight) div 2;
vTop := ARect.Top + vTop;
if AStyle.TextAlign = taLeftJustify then
vLeft := ARect.Left
else if AStyle.TextAlign = taRightJustify then
vLeft := ARect.Left + ColWidths[ACol] - vTextWidth - 6
else if AStyle.TextAlign = taCenter then
vLeft := ARect.Left + (ARect.Width - vTextWidth) div 2;
Canvas.TextRect(ARect, vLeft, vTop, vValue);
if AStyle.BorderActive and not (gdSelected in AState) then
begin
if AStyle.Border.Left.Enable then begin
Canvas.Pen.Width := AStyle.Border.FLeft.Width;
Canvas.Pen.Color := AStyle.Border.FLeft.Color;
Canvas.MoveTo(ARect.Left, ARect.Top);
Canvas.LineTo(ARect.Left, ARect.Bottom);
end;
if AStyle.Border.Right.Enable then begin
Canvas.Pen.Width := AStyle.Border.Right.Width;
Canvas.Pen.Color := AStyle.Border.Right.Color;
Canvas.MoveTo(ARect.Right, ARect.Top);
Canvas.LineTo(ARect.Right, ARect.Bottom);
end;
if AStyle.Border.Top.Enable then begin
Canvas.Pen.Width := AStyle.Border.Top.Width;
Canvas.Pen.Color := AStyle.Border.Top.Color;
Canvas.MoveTo(ARect.Left, ARect.Top);
Canvas.LineTo(ARect.Right, ARect.Top);
end;
if AStyle.Border.Bottom.Enable then begin
Canvas.Pen.Width := AStyle.Border.Bottom.Width;
Canvas.Pen.Color := AStyle.Border.Bottom.Color;
Canvas.MoveTo(ARect.Left, ARect.Bottom);
Canvas.LineTo(ARect.Right, ARect.Bottom);
end;
end;
if RowHeights[ARow] < vTextHeight then
RowHeights[ARow] := vTextHeight + LLineT + LLineB;
end;
end;
finally
Rows[ARow].EndUpdate;
Cols[ACol].EndUpdate;
end;
end;
end;
function TThsStringGrid.ExistsStyledCellItem(ARow, ACol: Integer): Integer;
var
n1, Len: Integer;
begin
Result := -1;
Len := FStyledCellItems.Count-1;
for n1 := 0 to Len do
begin
if (FStyledCellItems.Items[n1].RowNo = ARow)
and (FStyledCellItems.Items[n1].ColNo = ACol)
then
begin
Result := n1;
Break;
end;
end;
end;
function TThsStringGrid.GetStyledCellItem(Index: Integer): TThsStyledCell;
begin
Result := nil;
if Assigned(FStyledCellItems.Items[Index]) then
Result := FStyledCellItems.Items[Index];
end;
function TThsStringGrid.GetStyledCellItems: TObjectList<TThsStyledCell>;
begin
Result := FStyledCellItems;
end;
function TThsStringGrid.GetStyleFromStyledCells(Index: Integer): TThsStyle;
begin
Result := nil;
if Assigned(FStyledCellItems.Items[Index]) then
Result := FStyledCellItems.Items[Index].Style;
end;
procedure TThsStringGrid.SetStyledCellItems(const Value: TObjectList<TThsStyledCell>);
begin
FStyledCellItems := Value;
end;
function TThsStringGrid.ExistsStyledColItem(ACol: Integer): Integer;
var
n1, Len: Integer;
begin
Result := -1;
Len := FStyledColItems.Count-1;
for n1 := 0 to Len do
if (FStyledColItems.Items[n1].ColNo = ACol) then
Result := n1;
end;
function TThsStringGrid.GetStyledColItem(Index: Integer): TThsStyledCol;
begin
Result := nil;
if Assigned(FStyledColItems.Items[Index]) then
Result := FStyledColItems.Items[Index];
end;
function TThsStringGrid.GetStyledColItems: TObjectList<TThsStyledCol>;
begin
Result := FStyledColItems;
end;
function TThsStringGrid.GetStyleFromStyledCols(Index: Integer): TThsStyle;
begin
Result := nil;
if Assigned(FStyledColItems.Items[Index]) then
Result := FStyledColItems.Items[Index].Style;
end;
procedure TThsStringGrid.SetStyledColItems(const Value: TObjectList<TThsStyledCol>);
begin
FStyledColItems := Value;
end;
function TThsStringGrid.ExistsStyledRowItem(ARow: Integer): Integer;
var
n1, Len: Integer;
begin
Result := -1;
Len := FStyledRowItems.Count-1;
for n1 := 0 to Len do
if (FStyledRowItems.Items[n1].RowStartNo <= ARow)
and (FStyledRowItems.Items[n1].RowEndNo >= ARow)
then
Result := n1;
end;
function TThsStringGrid.GetStyledRowItem(Index: Integer): TThsStyledRow;
begin
Result := nil;
if Assigned(FStyledRowItems.Items[Index]) then
Result := FStyledRowItems.Items[Index];
end;
function TThsStringGrid.GetStyledRowItems: TObjectList<TThsStyledRow>;
begin
Result := FStyledRowItems;
end;
function TThsStringGrid.GetStyleFromStyledRows(Index: Integer): TThsStyle;
begin
Result := nil;
if Assigned(FStyledRowItems.Items[Index]) then
Result := FStyledRowItems.Items[Index].Style;
end;
procedure TThsStringGrid.SetStyledRowItems(const Value: TObjectList<TThsStyledRow>);
begin
FStyledRowItems := Value;
end;
{ TThsStringGridMenu
procedure TThsStringGridMenu.Executeverb(index: Integer);
begin
case index of
0: MessageDlg('TThsStringGrid © 2020 by Ferhat YILDIRIM | 3ddark', mtInformation, [mbOk], 0);
end;
Designer.Modified;
end;
function TThsStringGridMenu.GetVerb(index: Integer): String;
begin
case index of
0: GetVerb := '&About';
end;
end;
function TThsStringGridMenu.GetVerbCount: Integer;
begin
GetVerbCount := 1
end;
}
end.
KULLANIMI
unit Main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Grids,
thsEdit, thsStringGrid, Vcl.ExtCtrls;
type
TFormMain = class(TForm)
thsGrid1: TThsStringGrid;
Splitter1: TSplitter;
Panel1: TPanel;
btnResetGrid: TButton;
btnFillGrid: TButton;
procedure btnResetGridClick(Sender: TObject);
procedure btnFillGridClick(Sender: TObject);
procedure thsGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FormMain: TFormMain;
const
COL_SIRA = 0;
COL_KOD = 1;
COL_ACIKLAMA = 2;
COL_MIKTAR = 3;
COL_BIRIM = 4;
COL_FIYAT = 5;
COL_TUTAR = 6;
implementation
{$R *.dfm}
procedure TFormMain.btnFillGridClick(Sender: TObject);
var
nr: Integer;
nc: Integer;
LStyleCell, LStyleRow, LStyleCol: TThsStyle;
LStyledCell: TThsStyledCell;
LStyledRow: TThsStyledRow;
LStyledCol: TThsStyledCol;
begin
//Cell
LStyleCell := TThsStyle.Create;
with LStyleCell do
begin
Font.Style := [fsBold, fsStrikeOut];
Font.Color := clBlack;
Font.Size := 24;
Color := $00A9E2C7;
TextAlign := taLeftJustify;
BorderActive := False;
Border.Left.Enable := True;
Border.Left.Width := 1;
Border.Left.Color := $00DBBF75;
Border.Right.Enable := True;
Border.Right.Width := 1;
Border.Right.Color := $00DBBF75;
Border.Top.Enable := True;
Border.Top.Width := 1;
Border.Top.Color := $00DBBF75;
Border.Bottom.Enable := True;
Border.Bottom.Width := 1;
Border.Bottom.Color := $00DBBF75;
end;
LStyledCell := TThsStyledCell.Create;
LStyledCell.RowNo := 3;
LStyledCell.ColNo := 4;
LStyledCell.Style := LStyleCell;
thsGrid1.StyledCellItems.Add(LStyledCell);
//Row
LStyleRow := TThsStyle.Create;
LStyleRow.Assign(LStyleCell);
LStyleRow.Color := clCream;
LStyleRow.Font.Color := clBlue;
LStyleRow.Font.Style := [];
LStyleRow.Font.Size := 12;
LStyleRow.Font.Name := 'Comic Sans MS';
LStyleRow.TextAlign := taRightJustify;
LStyledRow := TThsStyledRow.Create;
LStyledRow.RowStartNo := 1;
LStyledRow.RowEndNo := 4;
LStyledRow.Style := LStyleRow;
thsGrid1.StyledRowItems.Add(LStyledRow);
//Col
LStyleCol := TThsStyle.Create;
LStyleCol.Assign(LStyleCell);
LStyleCol.Color := clNavy;
LStyleCol.Font.Color := clWhite;
LStyleCol.Font.Style := [];
LStyleCol.Font.Size := 12;
LStyleCol.Font.Name := 'Comic Sans MS';
LStyleCol.TextAlign := taRightJustify;
LStyledCol := TThsStyledCol.Create;
LStyledCol.ColNo := 4;
LStyledCol.Style := LStyleCol;
thsGrid1.StyledColItems.Add(LStyledCol);
LStyleCol := TThsStyle.Create;
LStyleCol.Assign(LStyleCell);
LStyleCol.Color := clRed;
LStyleCol.Font.Size := 10;
LStyleCol.Font.Style := [fsBold];
LStyleCol.Font.Color := clWhite;
LStyledCol := TThsStyledCol.Create;
LStyledCol.ColNo := 5;
LStyledCol.Style := LStyleCol;
thsGrid1.StyledColItems.Add(LStyledCol);
thsGrid1.RowCount := 10000;
thsGrid1.ColCount := 10;
thsGrid1.Cells[COL_SIRA, 0] := 'SIRA';
thsGrid1.Cells[COL_KOD, 0] := 'KOD';
thsGrid1.Cells[COL_ACIKLAMA, 0] := 'AÇIKLAMA';
thsGrid1.Cells[COL_MIKTAR, 0] := 'MİKTAR';
thsGrid1.Cells[COL_BIRIM, 0] := 'BİRİM';
thsGrid1.Cells[COL_FIYAT, 0] := 'FİYAT';
thsGrid1.Cells[COL_TUTAR, 0] := 'TUTAR';
for nr := 1 to thsGrid1.RowCount-1 do
for nc := 0 to thsGrid1.ColCount-1 do
thsGrid1.Cells[nc, nr] := ((nr * nc)).ToString;
end;
procedure TFormMain.btnResetGridClick(Sender: TObject);
var
n1: Integer;
begin
thsGrid1.ClearAllStyle;
thsGrid1.RowCount := 2;
thsGrid1.ColCount := 1;
thsGrid1.Rows[0].Clear;
for n1 := 0 to thsGrid1.ColCount-1 do
thsGrid1.Cols[n1].Clear;
end;
end.
PostgreSQL - Linux - Delphi, Poliüretan
