Konuyu Oyla:
  • Derecelendirme: 5/5 - 1 oy
  • 1
  • 2
  • 3
  • 4
  • 5
ThsStringGrid StringGrid Bileşeni
#1
KOMPONENT KODU
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
WWW
Cevapla
#2
Merhaba,
Emeklerinize sağlık @3ddark.
While true do; Hayat döngüsü, kısır değildir! Yapılan bir yanlış, o döngünün dışına çıkmanızı sağlayacaktır.
WWW
Cevapla
#3
Elinize saglık.
Cevapla
#4
Teşekkürler, @Fesih ARSLAN, @klavye İlerde yapacaklarımı GitHub üzerinden eklemelere devam edeceğim. Aslında Github üzerinde başka yayınladığım kodlarda mevcut. Özellikle Edit için bileşen var. Çok güzel en azından benim için çok kullanışlı.

ThsStringGrid için sonraki adımda ihtiyaca göre Column Sort, Grid için Find Text and Highlight ekleyeceğim. Belki alt toplam(Sum), Fixed Col ile Satır numaraları otomatik çıkması(Excel gibi) olabilir.
Bu arada boyama öncelikleri resimde görülüyor fakat özellikle buradan da belirteyim.
Column -> Row -> Cell
Ayrıca stringgrid drawcell özelliği ile de bu yaptığınız boyama stilerrini ezerek özel boyama da yapabiliyorsunuz.
PostgreSQL - Linux - Delphi, Poliüretan
WWW
Cevapla
#5
Class Helper olarak düzenledim.
Kullanımı: Aşağıdaki uniti projenize dahil etmeniz yeterli. Kullanmak istediğiniz (TStringGrid kullandığınız) form içine uses kısmına Ths.Erp.Helper.StringGrid uniti tanımlayın. Hepsi bu kadar.

Mevcut komponent kodunda bazı hatalarla karşılaştım. Bu hatalar düzeltildi ayrıca iyileştirme yapıldı. Ayrıca sıralama(Sort) özelliği eklendi. Şu anda sadece string olarak sıralama yapıyor. Asc ve Desc olarak çalışıyor. Şu anda 1 Fixed Row(Başlık için) olacak ve üzerine tıklama yapılan kolon için sıralama yapılyor. ilk tıklamada Asc aynı sütuna tekrar tıklama durumunda Desc olacak şekilde sıralama yapıyor.

Mevcut bir TStringGrid içeriğini DevExpress Excel bileşenini kullanarak bir Excel dosyaya kaydetmek için aşağıdaki kodu kullanabilirsiniz.

@uparlayan hocam daha önce özellik listesine eklemiş olduğunuz koşullu renklendirme kodunu ekledim.
Fixed Row ve Fixed Col için arkaplan rengi ve font özellikleri eklendi.
Fixed Col içinde arkaplan rengi ve font özellikleri eklendi.
Ayrıca hangi satırma olduğunu bildirmek amacıyla fixed col(satır numaralarının olduğu) sütununda aktif satır rengi eklendi.

   
iyileştirme yapıldı.

  pGrid.FixedRowColorBack := clRed;
 pGrid.FixedRowFont.Color := clWhite;
 pGrid.FixedRowFont.Style := [fsBold];

 pGrid.FixedColColorBack := clRed;
 pGrid.FixedColFont.Color := clWhite;
 pGrid.FixedColColorActive := clActiveCaption;

//bu eventler tanımlandığında aşağıdaki kod örneği de koşullu renklendirme için örnektir.
  strngrd1.OnConditionDrawCol := ConditionDrawCol;
  strngrd1.OnConditionDrawRow := ConditionDrawRow;
  strngrd1.OnConditionDrawCell := ConditionDrawCell;

procedure TfrmSatTeklifDetaylar.ConditionDrawCol(Sender: TObject; ACol: Integer; var Value: string; var AStyle: TThsStyle);
begin
 if ACol = ST_MIKTAR then
 begin
   if StrToIntDef(Value, 0) > 3 then
     AStyle.Color := clGreen
   else if StrToIntDef(Value, 0) < 3 then
     AStyle.Color := clRed
   else if StrToIntDef(Value, 0) = 3 then
     AStyle.Color := clGray;
 end;
end;

procedure TfrmBaseDetaylar.ExportExcel(AGrid: TStringGrid);
var
 LExcel: TdxSpreadSheet;
 nR, nC: Integer;
 LStyledCol: TThsStyle;
 LFileName: string;

 ATable: TdxSpreadSheetTableView;
 ACell: TdxSpreadSheetCell;

 function GetDialogSave(pFileName, pFilter: string; pInitialDir: string = ''): string;
 var
  LSaveDialog: TSaveDialog;
 begin
  Result := '';
  LSaveDialog := TSaveDialog.Create(nil);
  with LSaveDialog do
  try
    Filter := pFilter;
    FileName := pFileName;
    DefaultExt := pFilter.PadRight(3);
    if pInitialDir = '' then
      InitialDir := '%USERPROFILE%\desktop'
    else
      InitialDir := pInitialDir;

    if Execute(Application.Handle) then
      Result := FileName;
  finally
    LSaveDialog.Free;
  end;
 end;

begin
 LFileName := GetDialogSave('', 'Excel File|*.xlsx');
 if LFileName <> '' then
 begin
   LExcel := TdxSpreadSheet.Create(nil);
   try
     ATable := LExcel.ActiveSheetAsTable;
     ATable.Caption := 'ABC';

     //mevcut excel dosyası hücreler 0, 0 dan başlıyor
     for nR := 0 to AGrid.RowCount-1 do
     begin
       AGrid.Rows[nR].BeginUpdate;
       try
         for nC := 0 to AGrid.ColCount-1 do
         begin
           AGrid.Cols[nC].BeginUpdate;
           try
             ACell := ATable.CreateCell(nR, nC);
             ACell.Style.Font.Name := AGrid.Font.Name;
             ACell.Style.Font.Size := AGrid.Font.Size;

             LStyledCol := AGrid.GetStyleFromCell(nC, nR);

             if LStyledCol <> nil then
             begin
                 ACell.AsString := AGrid.Cells[nC, nR];

               if LStyledCol.TextAlign = TAlignment.taLeftJustify then
                 ACell.Style.AlignHorz := TdxSpreadSheetDataAlignHorz.ssahLeft
               else if LStyledCol.TextAlign = TAlignment.taRightJustify then
                 ACell.Style.AlignHorz := TdxSpreadSheetDataAlignHorz.ssahRight
               else if LStyledCol.TextAlign = TAlignment.taCenter then
                 ACell.Style.AlignHorz := TdxSpreadSheetDataAlignHorz.ssahCenter;

               if LStyledCol.Color <> clWhite then
                 ACell.Style.Brush.BackgroundColor := LStyledCol.Color;
               ACell.Style.Font.Name := LStyledCol.Font.Name;
               ACell.Style.Font.Style := LStyledCol.Font.Style;
               ACell.Style.Font.Size := LStyledCol.Font.Size;
               ACell.Style.Font.Color := LStyledCol.Font.Color;
             end
             else
               ACell.AsString := AGrid.Cells[nC, nR];

             ACell.Style.AlignVert := TdxSpreadSheetDataAlignVert.ssavCenter;
           finally
             AGrid.Cols[nC].EndUpdate;
           end;
         end;
       finally
         AGrid.Rows[nR].EndUpdate;
       end;
     end;

     LExcel.SaveToFile(LFileName);
   finally
     LExcel.Free;
   end;
 end;
end;

unit Ths.Erp.Helper.StringGrid;

interface

{$I ThsERP.inc}

uses
  System.SysUtils, System.Classes, System.Types, System.UITypes,
  System.Generics.Collections, System.Math, Winapi.Messages, Winapi.Windows,
  Vcl.Graphics, Vcl.Controls, Vcl.Grids, Vcl.Dialogs, Vcl.Forms;

const
  LEN_COL_ARRAY = 30;

  COL_OBJ = 0;
  ROW_OBJ = 0;

type
  TGridCracker = class(TCustomGrid);

  TSortMode = (smNone, smAsc, smDesc);

  TStyleValue = (svFont, svColor, svTextAlign, svBorder);
  TStyleValues = set of TStyleValue;

  TThsDataType = (ctString, ctInteger, ctDouble, ctDate, ctTime, ctDateTime, ctBcd, ctBoolean);

  TVerticalAlignment = (vaTop, vaCenter, vaBottom);

  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;
    FHAlign: TAlignment;
    FVAlign: TVerticalAlignment;
    FBorder: TThsCellBorder;
    FBorderActive: Boolean;
    FStyleName: string;
  published
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Clone: TThsStyle;
  published
    property Font: TFont read FFont write FFont;
    property Color: TColor read FColor write FColor;
    property HAlign: TAlignment read FHAlign write FHAlign;
    property VAlign: TVerticalAlignment read FVAlign write FVAlign;
    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: TArray<ShortInt>;
    FStyle: TThsStyle;
    FDataType: TThsDataType;
    function GetColNo: TArray<ShortInt>;
    function GetStyle: TThsStyle;
    function GetFDataType: TThsDataType;
    procedure SetColNo(const Value: TArray<ShortInt>);
    procedure SetStyle(const Value: TThsStyle);
    procedure SetDataType(const Value: TThsDataType);
  public
    constructor Create();
    destructor Destroy; override;
  published
    property ColNo: TArray<ShortInt> read GetColNo write SetColNo;
    property Style: TThsStyle read GetStyle write SetStyle;
    property DataType: TThsDataType read GetFDataType write SetDataType;
  end;

  TOnConditionDrawCol = procedure(Sender: TObject; ACol: Longint; var Value: string; var AStyle: TThsStyle) of object;
  TOnConditionDrawRow = procedure(Sender: TObject; ARow: Longint; var Value: string; var AStyle: TThsStyle) of object;
  TOnConditionDrawCell = procedure(Sender: TObject; ARow, ACol: Longint; var Value: string; var AStyle: TThsStyle) of object;

  TStringGrid = class(Vcl.Grids.TStringGrid)
  private
    // use for column sort
    FSortCol: SmallInt;
    FSortType: TSortMode;

    FColResized: Boolean;

    FFixedRowColorBack: TColor;
    FFixedRowFont: TFont;

    FFixedColColorBack: TColor;
    FFixedColColorActive: TColor;
    FFixedColFont: TFont;

    FSortArrowBorderColor: TColor;
    FSortArrowBackColor: TColor;

    FCheck: TBitmap;
    FNoCheck: TBitmap;

    // Kolon veri tipini ilk aşamada sıralama yapmak için kullanıyoruz.
    FColDataTypes: TArray<TThsDataType>;

    FStyledCellItems: TObjectList<TThsStyledCell>;
    FStyledRowItems: TObjectList<TThsStyledRow>;
    FStyledColItems: TObjectList<TThsStyledCol>;

    FOnConditionDrawCol: TOnConditionDrawCol;
    FOnConditionDrawRow: TOnConditionDrawRow;
    FOnConditionDrawCell: TOnConditionDrawCell;

    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>);
    function GetColDataType(Index: Integer): TThsDataType;
    procedure SetColDataType(Index: Integer; Value: TThsDataType);
    procedure DrawFixedRowNumber;
    procedure DrawSortArrow(ARect: TRect; ASort: TSortMode; AAlign: TAlignment);
  protected
    procedure DrawCell(ACol: Integer; ARow: Integer; ARect: TRect; AState: TGridDrawState); override;
    procedure ColumnMoved(FromIndex: Integer; ToIndex: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure FixedCellClick(ACol, ARow: Longint); override;
    procedure ColWidthsChanged; override;
    procedure SizeChanged(OldColCount, OldRowCount: Longint); override;

    procedure SortStringGrid(ACol: Integer);
    procedure SortMerge(var ARowNoList: array of Integer; ACol: Integer; ASortMode: TSortMode);

    procedure ConditionDrawCol(Sender: TObject; ACol: Longint; var Value: string; var AStyle: TThsStyle);
    procedure ConditionDrawRow(Sender: TObject; ARow: Longint; var Value: string; var AStyle: TThsStyle);
    procedure ConditionDrawCell(Sender: TObject; ARow, ACol: Longint; var Value: string; var AStyle: TThsStyle);
  published
    property OnConditionDrawCol: TOnConditionDrawCol read FOnConditionDrawCol write FOnConditionDrawCol;
    property OnConditionDrawRow: TOnConditionDrawRow read FOnConditionDrawRow write FOnConditionDrawRow;
    property OnConditionDrawCell: TOnConditionDrawCell read FOnConditionDrawCell write FOnConditionDrawCell;
    function SelectCell(ACol, ARow: Longint): Boolean; 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 GetStyledCellItemByColRow(ACol, ARow: Integer): 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 GetStyledRowItemByRowNo(ARow: Integer): 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;
    function GetStyledColItemByColNo(ACol: Integer): TThsStyledCol;

    property SortCol: SmallInt read FSortCol write FSortCol;
    property SortType: TSortMode read FSortType write FSortType;
    property ColDataTypes[Index: Longint]: TThsDataType read GetColDataType write SetColDataType;
    property FixedRowColorBack: TColor read FFixedRowColorBack write FFixedRowColorBack;
    property FixedRowFont: TFont read FFixedRowFont write FFixedRowFont;
    property FixedColColorBack: TColor read FFixedColColorBack write FFixedColColorBack;
    property FixedColColorActive: TColor read FFixedColColorActive write FFixedColColorActive;
    property FixedColFont: TFont read FFixedColFont write FFixedColFont;

    function GetStyleFromCell(ACol, ARow: Integer): TThsStyle;

    procedure PrepareGrid;
  end;

implementation

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;

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;

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.FHAlign := TThsStyle(Source).HAlign;
    Self.FVAlign := TThsStyle(Source).VAlign;
    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;

function TThsStyle.Clone: TThsStyle;
begin
  Result := TThsStyle.Create;

  Result.FFont.Color := Self.FFont.Color;
  Result.FFont.Name := Self.FFont.Name;
  Result.FFont.Size := Self.FFont.Size;
  Result.FFont.Style := Self.FFont.Style;

  Result.HAlign := Self.HAlign;
  Result.VAlign := Self.VAlign;

  Result.FBorder.FLeft.FEnable := Self.FBorder.FLeft.FEnable;
  Result.FBorder.FLeft.FColor := Self.FBorder.FLeft.FColor;
  Result.FBorder.FLeft.FWidth := Self.FBorder.FLeft.FWidth;

  Result.FBorder.FRight.FEnable := Self.FBorder.FRight.FEnable;
  Result.FBorder.FRight.FColor := Self.FBorder.FRight.FColor;
  Result.FBorder.FRight.FWidth := Self.FBorder.FRight.FWidth;

  Result.FBorder.FTop.FEnable := Self.FBorder.FTop.FEnable;
  Result.FBorder.FTop.FColor := Self.FBorder.FTop.FColor;
  Result.FBorder.FTop.FWidth := Self.FBorder.FTop.FWidth;

  Result.FBorder.FBottom.FEnable := Self.FBorder.FBottom.FEnable;
  Result.FBorder.FBottom.FColor := Self.FBorder.FBottom.FColor;
  Result.FBorder.FBottom.FWidth := Self.FBorder.FBottom.FWidth;

  Result.FBorderActive := Self.FBorderActive;
end;

constructor TThsStyle.Create();
begin
  FFont := TFont.Create;
  FColor := clWhite;
  FHAlign := taLeftJustify;
  FVAlign := vaCenter;

  FBorder := TThsCellBorder.Create;
  FBorderActive := False;
end;

destructor TThsStyle.Destroy;
begin
  if FFont <> nil then
    FreeAndNil(FFont);
  if FBorder <> nil then
    FreeAndNil(FBorder);
  inherited;
end;

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;

constructor TThsStyledCol.Create();
var
  n1: Integer;
begin
  inherited;
  SetLength(FColNo, LEN_COL_ARRAY);
  for n1 := 0 to LEN_COL_ARRAY - 1 do
    FColNo[n1] := -1;
  FStyle := TThsStyle.Create;
  FDataType := ctString;
end;

destructor TThsStyledCol.Destroy;
begin
  if FStyle <> nil then
    FreeAndNil(FStyle);
  inherited;
end;

function TThsStyledCol.GetColNo: TArray<ShortInt>;
begin
  Result := FColNo;
end;

function TThsStyledCol.GetStyle: TThsStyle;
begin
  Result := FStyle;
end;

function TThsStyledCol.GetFDataType: TThsDataType;
begin
  Result := FDataType;
end;

procedure TThsStyledCol.SetColNo(const Value: TArray<ShortInt>);
begin
  FColNo := Value;
end;

procedure TThsStyledCol.SetStyle(const Value: TThsStyle);
begin
  FStyle := Value;
end;

procedure TThsStyledCol.SetDataType(const Value: TThsDataType);
begin
  FDataType := Value;
end;

constructor TThsStyledRow.Create();
begin
  inherited;
  FRowType := rtRow;
  FStyle := TThsStyle.Create;
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;

function TStringGrid.AddStyledCell: TThsStyledCell;
begin
  PrepareGrid;
  Result := TThsStyledCell.Create;
  Result.Style.FFont.Name := Self.Font.Name;
  Result.Style.FFont.Size := Self.Font.Size;
  Result.Style.FFont.Style := Self.Font.Style;

  FStyledCellItems.Add(Result);
end;

function TStringGrid.AddStyledCol: TThsStyledCol;
begin
  PrepareGrid;
  Result := TThsStyledCol.Create;
  Result.Style.FFont.Name := Self.Font.Name;
  Result.Style.FFont.Size := Self.Font.Size;
  Result.Style.FFont.Style := Self.Font.Style;

  FStyledColItems.Add(Result);
end;

function TStringGrid.AddStyledRow: TThsStyledRow;
begin
  PrepareGrid;
  Result := TThsStyledRow.Create;
  Result.Style.FFont.Name := Self.Font.Name;
  Result.Style.FFont.Size := Self.Font.Size;
  Result.Style.FFont.Style := Self.Font.Style;

  FStyledRowItems.Add(Result);
end;

procedure TStringGrid.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 TStringGrid.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 TStringGrid.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 TStringGrid.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 TStringGrid.ColumnMoved(FromIndex, ToIndex: Integer);
var
  n1, Len: Integer;
  IsFromStyled, IsToStyled: Boolean;
  LFromStyleIdx, LFromColIdx, LToStyleIdx, LToColIdx: Integer;
  n2: Integer;
begin
  inherited;

  IsFromStyled := False;
  IsToStyled := False;

  LFromStyleIdx := -1;
  LFromColIdx := -1;
  LToStyleIdx := -1;
  LToColIdx := -1;

  Len := FStyledColItems.Count - 1;
  for n1 := 0 to Len do
    for n2 := 0 to Length(FStyledColItems.Items[n1].ColNo) - 1 do
      if (FStyledColItems.Items[n1].ColNo[n2] = FromIndex) then
      begin
        LFromStyleIdx := n1;
        LFromColIdx := n2;
        IsFromStyled := True;
      end;

  for n1 := 0 to Len do
    for n2 := 0 to Length(FStyledColItems.Items[n1].ColNo) - 1 do
      if (FStyledColItems.Items[n1].ColNo[n2] = ToIndex) then
      begin
        LToStyleIdx := n1;
        LToColIdx := n2;
        IsToStyled := True;
      end;

  if IsFromStyled and not IsToStyled then
    FStyledColItems.Items[LFromStyleIdx].ColNo[LFromColIdx] := ToIndex;

  if not IsFromStyled and IsToStyled then
    FStyledColItems.Items[LToStyleIdx].ColNo[LToColIdx] := FromIndex;

  if IsFromStyled and IsToStyled then
  begin
    FStyledColItems.Items[LFromStyleIdx].ColNo[LFromColIdx] := ToIndex;
    FStyledColItems.Items[LToStyleIdx].ColNo[LToColIdx] := FromIndex;
  end;

  Self.Invalidate;
end;

constructor TStringGrid.Create(AOwner: TComponent);
var
  n1: Integer;
  LBmp: TBitmap;
begin
  inherited Create(AOwner);
  Self.DoubleBuffered := True;

  FSortCol := -1;
  FSortType := smNone;

  FFixedRowColorBack := FixedColor;
  FFixedRowFont := TFont.Create;
  FFixedRowFont.Color := Font.Color;
  FFixedRowFont.Name := Font.Name;
  FFixedRowFont.Size := Font.Size;
  FFixedRowFont.Style := Font.Style;

  FFixedColColorBack := FixedColor;
  FixedColColorActive := FixedColor;
  FFixedColFont := TFont.Create;
  FFixedColFont.Color := Font.Color;
  FFixedColFont.Name := Font.Name;
  FFixedColFont.Size := Font.Size;
  FFixedColFont.Style := Font.Style;

  FSortArrowBorderColor := clBlack;
  FSortArrowBackColor := clBlack;

  SetLength(FColDataTypes, ColCount - FixedCols);
  for n1 := 0 to Length(FColDataTypes) - 1 do
    FColDataTypes[n1] := ctString;

  FStyledCellItems := TObjectList<TThsStyledCell>.Create;
  FStyledRowItems := TObjectList<TThsStyledRow>.Create;
  FStyledColItems := TObjectList<TThsStyledCol>.Create;

  // use for draw checkbox
  FCheck := TBitmap.Create;
  FNoCheck := TBitmap.Create;
  LBmp := TBitmap.Create;
  try
    LBmp.Handle := LoadBitmap(0, PChar(OBM_CHECKBOXES));

    with FNoCheck do
    begin
      Width := LBmp.Width div 4;
      Height := LBmp.Height div 3;
      Canvas.CopyRect(Canvas.ClipRect, LBmp.Canvas, Canvas.ClipRect);
    end;

    with FCheck do
    begin
      Width := LBmp.Width div 4;
      Height := LBmp.Height div 3;
      Canvas.CopyRect(Canvas.ClipRect, LBmp.Canvas, Rect(Width, 0, 2 * Width, Height));
    end;
  finally
    LBmp.Free;
  end;
end;

destructor TStringGrid.Destroy;
begin
  FCheck.Free;
  FNoCheck.Free;

  FStyledCellItems.Free;
  FStyledRowItems.Free;
  FStyledColItems.Free;

  FFixedRowFont.Free;
  FFixedColFont.Free;

  inherited;
end;

procedure TStringGrid.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;
  LStyle: TThsStyle;

  function HorizontalAlignment: Integer;
  begin
    Result := ARect.Left;
    if LStyle.HAlign = taLeftJustify then
      Result := ARect.Left + 2
    else if LStyle.HAlign = taRightJustify then
      Result := ARect.Right - vTextWidth - 2
    else if LStyle.HAlign = taCenter then
      Result := ARect.Left + (ARect.Width - vTextWidth) div 2;
  end;

  function VerticalAlignment: Integer;
  begin
    Result := ARect.Top;
    if LStyle.VAlign = vaTop then
      Result := ARect.Top + 2
    else if LStyle.VAlign = vaBottom then
      Result := ARect.Bottom - vTextHeight - 2
    else if LStyle.VAlign = vaCenter then
      Result := ARect.Top + (ARect.Height - vTextHeight) div 2;
  end;

  procedure DrawBorders;
  begin
    if LStyle.BorderActive and not(gdSelected in AState) then
    begin
      if LStyle.Border.Left.Enable then
      begin
        Canvas.Pen.Width := LStyle.Border.FLeft.Width;
        Canvas.Pen.Color := LStyle.Border.FLeft.Color;
        Canvas.MoveTo(ARect.Left, ARect.Top);
        Canvas.LineTo(ARect.Left, ARect.Bottom);
      end;

      if LStyle.Border.Right.Enable then
      begin
        Canvas.Pen.Width := LStyle.Border.Right.Width;
        Canvas.Pen.Color := LStyle.Border.Right.Color;
        Canvas.MoveTo(ARect.Right, ARect.Top);
        Canvas.LineTo(ARect.Right, ARect.Bottom);
      end;

      if LStyle.Border.Top.Enable then
      begin
        Canvas.Pen.Width := LStyle.Border.Top.Width;
        Canvas.Pen.Color := LStyle.Border.Top.Color;
        Canvas.MoveTo(ARect.Left, ARect.Top);
        Canvas.LineTo(ARect.Right, ARect.Top);
      end;

      if LStyle.Border.Bottom.Enable then
      begin
        Canvas.Pen.Width := LStyle.Border.Bottom.Width;
        Canvas.Pen.Color := LStyle.Border.Bottom.Color;
        Canvas.MoveTo(ARect.Left, ARect.Bottom);
        Canvas.LineTo(ARect.Right, ARect.Bottom);
      end;
    end;
  end;

  procedure PrepareBorderRect;
  begin
    if LStyle.BorderActive then
    begin
      if LStyle.Border.Left.Enable then
        LLineL := LStyle.FBorder.FLeft.Width;
      if LStyle.Border.Right.Enable then
        LLineR := LStyle.Border.Right.Width;
      if LStyle.Border.Top.Enable then
        LLineT := LStyle.Border.Top.Width;
      if LStyle.Border.Bottom.Enable then
        LLineB := LStyle.Border.Bottom.Width;
    end;

    Canvas.Font := LStyle.Font;
    Canvas.Brush.Color := LStyle.Color;

    ARect.Left := ARect.Left + LLineL;
    ARect.Right := ARect.Right - LLineR;
    ARect.Top := ARect.Top + LLineT;
    ARect.Bottom := ARect.Bottom - LLineB;

    Canvas.FillRect(ARect);
  end;

begin
  inherited;
  if not(csDesigning in Self.ComponentState) then
  begin
    LStyle := nil;

    Rows[ARow].BeginUpdate;
    Cols[ACol].BeginUpdate;
    try
      vValue := Cells[ACol, ARow];

      // Draw fixed col
      if (ACol + 1 <= FixedCols) then
      begin
        if ARow = Row then
          Canvas.Brush.Color := FFixedColColorActive
        else
          Canvas.Brush.Color := FFixedColColorBack;
        Canvas.Font.Name := FFixedColFont.Name;
        Canvas.Font.Size := FFixedColFont.Size;
        Canvas.Font.Color := FFixedColFont.Color;
        Canvas.Font.Style := FFixedColFont.Style;
        Canvas.FillRect(ARect);

        vTextWidth := Canvas.TextWidth(vValue);
        vTextHeight := Canvas.TextHeight(vValue);
        vTop := (ARect.Height - vTextHeight) div 2;
        vTop := ARect.Top + vTop;
        vLeft := ARect.Left + ColWidths[ACol] - vTextWidth - 6;

        ColWidths[ACol] := Max(vTextWidth + 6 * 2, ColWidths[ACol]);
        Canvas.TextRect(ARect, vLeft, vTop, vValue);
      end;

      // Draw fixed row
      if (ARow + 1 <= FixedRows) then
      begin
        Canvas.Brush.Color := FFixedRowColorBack;
        Canvas.Font.Name := FFixedRowFont.Name;
        Canvas.Font.Size := FFixedRowFont.Size;
        Canvas.Font.Color := FFixedRowFont.Color;
        Canvas.Font.Style := FFixedRowFont.Style;
        Canvas.FillRect(ARect);

        vTextWidth := Canvas.TextWidth(vValue);
        vTextHeight := Canvas.TextHeight(vValue);
        vTop := (ARect.Height - vTextHeight) div 2;
        vTop := ARect.Top + vTop;
        vLeft := ARect.Left + (ARect.Width - vTextWidth) div 2;

        RowHeights[ARow] := Max(vTextHeight + 3 * 2, RowHeights[ARow]);
        Canvas.TextRect(ARect, vLeft, vTop, vValue);
      end;

      // col style   fixed col haricinde boyama yap
      if (ACol + 1 > FixedCols) and (ARow + 1 > FixedRows) then
      begin
        LStyleIdx := ExistsStyledColItem(ACol);
        if LStyleIdx > -1 then
        begin
          LLineL := 0;
          LLineR := 0;
          LLineT := 0;
          LLineB := 0;

          AStyle := GetStyleFromStyledCols(LStyleIdx);

          if AStyle <> nil then
          begin
            LStyle := AStyle.Clone;
            try
              ConditionDrawCol(Self, ACol, vValue, LStyle);

              PrepareBorderRect;

              vTextWidth := Canvas.TextWidth(vValue);
              vTextHeight := Canvas.TextHeight(vValue);

              vTop := VerticalAlignment;
              vLeft := HorizontalAlignment;

              Canvas.TextRect(ARect, vLeft, vTop, vValue);

              DrawBorders;

              if ColWidths[ACol] < vTextWidth then
                ColWidths[ACol] := vTextWidth + LLineL + LLineR;
            finally
              if (LStyle <> nil) then
                FreeAndNil(LStyle);
            end;
          end;
        end;
      end; { col draw }

      // row style   fixed row haricinde boyama yap
      if (ACol + 1 > FixedCols) and (ARow + 1 > FixedRows) then
      begin
        LStyleIdx := ExistsStyledRowItem(ARow);
        if LStyleIdx > -1 then
        begin
          LLineL := 0;
          LLineR := 0;
          LLineT := 0;
          LLineB := 0;

          AStyle := GetStyleFromStyledRows(LStyleIdx);
          if AStyle <> nil then
          begin
            LStyle := AStyle.Clone;
            try
              ConditionDrawRow(Self, ARow, vValue, LStyle);

              PrepareBorderRect;

              vTextWidth := Canvas.TextWidth(vValue);
              vTextHeight := Canvas.TextHeight(vValue);

              vTop := VerticalAlignment;
              vLeft := HorizontalAlignment;

              Canvas.TextRect(ARect, vLeft, vTop, vValue);

              DrawBorders;

              if RowHeights[ARow] < vTextHeight then
                RowHeights[ARow] := vTextHeight + LLineT + LLineB;
            finally
              if (LStyle <> nil) then
                FreeAndNil(LStyle);
            end;
          end;
        end;
      end; { row draw }

      // cell style    fixed row ve col haricinde boyama yap
      if (ACol + 1 > FixedCols) and (ARow + 1 > FixedRows) then
      begin
        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
            LStyle := AStyle.Clone;
            try
              ConditionDrawCell(Self, ARow, ACol, vValue, LStyle);

              PrepareBorderRect;

              vTextWidth := Canvas.TextWidth(vValue);
              vTextHeight := Canvas.TextHeight(vValue);

              vTop := VerticalAlignment;
              vLeft := HorizontalAlignment;

              Canvas.TextRect(ARect, vLeft, vTop, vValue);

              DrawBorders;

              if RowHeights[ARow] < vTextHeight then
                RowHeights[ARow] := vTextHeight + LLineT + LLineB;
            finally
              if (LStyle <> nil) then
                FreeAndNil(LStyle);
            end;
          end;
        end;
      end; { cell draw }

      if (ARow + 1 <= FixedRows) and (FSortType <> TSortMode.smNone) and (FSortCol = ACol) then
        DrawSortArrow(ARect, FSortType, taRightJustify);

    finally
      Rows[ARow].EndUpdate;
      Cols[ACol].EndUpdate;
    end;
  end;

  // Draw Checkbox
  // Daha sonra aktif edilecek şu anda veri tipi boolean ise ve hücre bilgisi true='TRUE' false='FALSE' bilgisi tanımlı değil
  if FColDataTypes[ACol] = ctBoolean then
  begin
    if (ARow + 1 > FixedRows) and ((Cells[ACol, ARow] = 'TRUE') or (Cells[ACol, ARow] = 'FALSE')) then
      with Canvas do
      Begin
        FillRect(ARect);
        if Cells[ACol, ARow] = 'TRUE' then  // use for my global function true = 'TRUE' false = 'FALSE'
          Draw((ARect.Right + ARect.Left - FCheck.Width) div 2, (ARect.Bottom + ARect.Top - FCheck.Height) div 2, FCheck)
        else if Cells[ACol, ARow] = 'FALSE' then
          Draw((ARect.Right + ARect.Left - FNoCheck.Width) div 2, (ARect.Bottom + ARect.Top - FNoCheck.Height) div 2, FNoCheck)
      end;
  end;
end;

procedure TStringGrid.DrawFixedRowNumber;
var
  nR, RowNo: Integer;
begin
  Perform(WM_SETREDRAW, 0, 0);
  try
    if FixedCols > 0 then
    begin
      RowNo := 1;
      for nR := FixedRows to RowCount - 1 do
      begin
        Rows[nR].BeginUpdate;
        try
          if RowHeights[nR] > 0 then
          begin
            Cells[0, nR] := RowNo.ToString;
            Inc(RowNo);
          end;
        finally
          Rows[nR].EndUpdate;
        end;
      end;
    end;
  finally
    Perform(WM_SETREDRAW, 1, 0);
    Invalidate;
  end;
end;

procedure TStringGrid.DrawSortArrow(ARect: TRect; ASort: TSortMode; AAlign: TAlignment);
const
  OFFSET = 2;
var
  goLeft: Integer;
begin
  // if AAlign = taLeftJustify then
  goLeft := 0;
  // else
  // goLeft := ARect.Right - ARect.Left - 10;

  // draw triangle
  Canvas.Brush.Color := FSortArrowBackColor;
  Canvas.Pen.Color := FSortArrowBorderColor;
  if ASort = smAsc then
    Canvas.Polygon([Point(OFFSET + ARect.Left + goLeft + 5,
      OFFSET + ARect.Top + 5), Point(OFFSET + ARect.Left + goLeft + 2,
      OFFSET + ARect.Top + 10), Point(OFFSET + ARect.Left + goLeft + 8,
      OFFSET + ARect.Top + 10)])
  else if ASort = smDesc then
    Canvas.Polygon([Point(OFFSET + ARect.Left + goLeft + 2,
      OFFSET + ARect.Top + 5), Point(OFFSET + ARect.Left + goLeft + 8,
      OFFSET + ARect.Top + 5), Point(OFFSET + ARect.Left + goLeft + 5,
      OFFSET + ARect.Top + 10)]);
end;

function TStringGrid.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 TStringGrid.GetColDataType(Index: Integer): TThsDataType;
begin
  Result := FColDataTypes[Index];
end;

function TStringGrid.GetStyledCellItem(Index: Integer): TThsStyledCell;
begin
  Result := nil;
  if Assigned(FStyledCellItems.Items[Index]) then
    Result := FStyledCellItems.Items[Index];
end;

function TStringGrid.GetStyledCellItems: TObjectList<TThsStyledCell>;
begin
  Result := FStyledCellItems;
end;

function TStringGrid.GetStyleFromStyledCells(Index: Integer): TThsStyle;
begin
  Result := nil;
  if Assigned(FStyledCellItems.Items[Index]) then
    Result := FStyledCellItems.Items[Index].Style;
end;

function TStringGrid.SelectCell(ACol, ARow: Longint): Boolean;
begin
  Result := inherited SelectCell(ACol, ARow);
  if Result then
    Invalidate;
end;

procedure TStringGrid.SetColDataType(Index: Integer; Value: TThsDataType);
begin
  if (Length(FColDataTypes) <> ColCount - FixedCols) then
    SetLength(FColDataTypes, ColCount - FixedCols);

  FColDataTypes[Index] := Value;
end;

procedure TStringGrid.SetStyledCellItems(const Value: TObjectList<TThsStyledCell>);
begin
  FStyledCellItems := Value;
end;

function TStringGrid.ExistsStyledColItem(ACol: Integer): Integer;
var
  n1, Len: Integer;
  n2: Integer;
begin
  Result := -1;
  Len := FStyledColItems.Count - 1;
  for n1 := 0 to Len do
    for n2 := 0 to Length(FStyledColItems.Items[n1].ColNo) - 1 do
      if (FStyledColItems.Items[n1].ColNo[n2] = ACol) then
        Result := n1;
end;

function TStringGrid.GetStyledColItem(Index: Integer): TThsStyledCol;
begin
  Result := nil;
  if Assigned(FStyledColItems.Items[Index]) then
    Result := FStyledColItems.Items[Index];
end;

function TStringGrid.GetStyledColItems: TObjectList<TThsStyledCol>;
begin
  Result := FStyledColItems;
end;

function TStringGrid.GetStyleFromStyledCols(Index: Integer): TThsStyle;
begin
  Result := nil;
  if Assigned(FStyledColItems.Items[Index]) then
    Result := FStyledColItems.Items[Index].Style;
end;

procedure TStringGrid.SetStyledColItems(const Value
  : TObjectList<TThsStyledCol>);
begin
  FStyledColItems := Value;
end;

function TStringGrid.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 TStringGrid.GetStyledRowItem(Index: Integer): TThsStyledRow;
begin
  Result := nil;
  if Assigned(FStyledRowItems.Items[Index]) then
    Result := FStyledRowItems.Items[Index];
end;

function TStringGrid.GetStyledRowItems: TObjectList<TThsStyledRow>;
begin
  Result := FStyledRowItems;
end;

function TStringGrid.GetStyleFromStyledRows(Index: Integer): TThsStyle;
begin
  Result := nil;
  if Assigned(FStyledRowItems.Items[Index]) then
    Result := FStyledRowItems.Items[Index].Style;
end;

procedure TStringGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  ACol, ARow: Integer;
begin
  FColResized := False;
  inherited;

  if (Button = mbLeft) and not FColResized then
  begin
    MouseToCell(X, Y, ACol, ARow);
    if FixedCols - 1 < ACol then
      if ARow > -1 then // sınır dışında tıklama olursa
        if ARow <= FixedRows - 1 then
          SortStringGrid(ACol);
  end;
end;

procedure TStringGrid.FixedCellClick(ACol, ARow: Longint);
begin
  //
  inherited;
end;

procedure TStringGrid.ColWidthsChanged;
begin
  inherited;
  FColResized := True;
end;

procedure TStringGrid.ConditionDrawCell(Sender: TObject; ARow, ACol: Longint; var Value: string; var AStyle: TThsStyle);
begin
  if Assigned(FOnConditionDrawCell) then
    FOnConditionDrawCell(Sender, ACol, ARow, Value, AStyle);
end;

procedure TStringGrid.ConditionDrawCol(Sender: TObject; ACol: Longint; var Value: string; var AStyle: TThsStyle);
begin
  if Assigned(FOnConditionDrawCol) then
    FOnConditionDrawCol(Self, ACol, Value, AStyle);
end;

procedure TStringGrid.ConditionDrawRow(Sender: TObject; ARow: Longint; var Value: string; var AStyle: TThsStyle);
begin
  if Assigned(FOnConditionDrawRow) then
    FOnConditionDrawRow(Sender, ARow, Value, AStyle);
end;

procedure TStringGrid.SizeChanged(OldColCount, OldRowCount: Longint);
begin
  DrawFixedRowNumber;
end;

function TStringGrid.GetStyledCellItemByColRow(ACol, ARow: Integer) : TThsStyledCell;
var
  n1: Integer;
begin
  Result := nil;

  for n1 := 0 to FStyledCellItems.Count - 1 do
    if (FStyledCellItems[n1].FRowNo = ARow) and (FStyledCellItems[n1].FColNo = ACol) then
    begin
      Result := FStyledCellItems[n1];
      Exit;
    end;
end;

function TStringGrid.GetStyledRowItemByRowNo(ARow: Integer): TThsStyledRow;
var
  n1: Integer;
begin
  Result := nil;

  for n1 := 0 to FStyledRowItems.Count - 1 do
    if (FStyledRowItems[n1].FRowStartNo >= ARow) and (FStyledRowItems[n1].FRowEndNo <= ARow) then
    begin
      Result := FStyledRowItems[n1];
      Exit;
    end;
end;

function TStringGrid.GetStyledColItemByColNo(ACol: Integer): TThsStyledCol;
var
  n1, n2: Integer;
begin
  Result := nil;

  for n1 := 0 to FStyledColItems.Count - 1 do
    for n2 := 0 to Length(FStyledColItems[n1].ColNo) - 1 do
      if ACol = FStyledColItems[n1].ColNo[n2] then
      begin
        Result := FStyledColItems[n1];
        Exit;
      end;
end;

function TStringGrid.GetStyleFromCell(ACol, ARow: Integer): TThsStyle;
var
  LStyleCol: TThsStyledCol;
  LStyleRow: TThsStyledRow;
  LStyleCell: TThsStyledCell;
begin
  Result := nil;

  LStyleCol := GetStyledColItemByColNo(ACol);
  if LStyleCol <> nil then
    Result := LStyleCol.FStyle;

  LStyleRow := GetStyledRowItemByRowNo(ARow);
  if LStyleRow <> nil then
    Result := LStyleRow.FStyle;

  LStyleCell := GetStyledCellItemByColRow(ACol, ARow);
  if LStyleCell <> nil then
    Result := LStyleCell.FStyle;
end;

procedure TStringGrid.PrepareGrid;
begin
  Self.DoubleBuffered := True;

  if FStyledCellItems = nil then
    FStyledCellItems := TObjectList<TThsStyledCell>.Create;
  if FStyledRowItems = nil then
    FStyledRowItems := TObjectList<TThsStyledRow>.Create;
  if FStyledColItems = nil then
    FStyledColItems := TObjectList<TThsStyledCol>.Create;
end;

procedure TStringGrid.SetStyledRowItems(const Value
  : TObjectList<TThsStyledRow>);
begin
  FStyledRowItems := Value;
end;

procedure TStringGrid.SortStringGrid(ACol: Integer);
var
  n1: Integer;
  LSortType: TSortMode;
  LTempGrid: TStringGrid;
  LRowNoList: array of Integer;
begin
  Screen.Cursor := crHourGlass;
  Perform(WM_SETREDRAW, 0, 0);
  Cols[ACol].BeginUpdate;
  LTempGrid := TStringGrid.Create(Self);
  try
    LSortType := smNone;

    LTempGrid.RowCount := Self.RowCount;
    LTempGrid.ColCount := Self.ColCount;
    LTempGrid.FixedRows := Self.FixedRows;

    SetLength(LRowNoList, RowCount - FixedRows);

    // fill sorted grid row numbers and fill grid rows to tempgrid rows
    for n1 := FixedRows to RowCount - 1 do
    begin
      LRowNoList[n1 - FixedRows] := n1;
      LTempGrid.Rows[n1].Assign(Rows[n1]);
    end;


    if (FSortType = smNone) // first sort
    or (FSortCol <> ACol) // sort col is different from last sort col
    or ((FSortType = smDesc) and (FSortCol = ACol))  // sort col same as last sort col and last sort is desc
    then
      LSortType := smAsc
    else if (FSortType = smAsc) and (FSortCol = ACol) then  // sort col same as last sort col and last sort is asc
      LSortType := smDesc;

    SortMerge(LRowNoList, ACol, LSortType);

    for n1 := 0 to RowCount - FixedRows - 1 do
      Rows[n1 + FixedRows].Assign(LTempGrid.Rows[LRowNoList[n1]]);

    Row := FixedRows;

    FSortType := LSortType;
    FSortCol := ACol;
  finally
    Cols[ACol].EndUpdate;
    LTempGrid.Free;
    SetLength(LRowNoList, 0);
    Screen.Cursor := crDefault;

    Perform(WM_SETREDRAW, 1, 0);

    DrawFixedRowNumber;

    Invalidate;
  end;
end;

procedure TStringGrid.SortMerge(var ARowNoList: array of Integer; ACol: Integer; ASortMode: TSortMode);
var
  AVals: array of Integer;

  function Compare(Value1, Value2: string): Integer;
  begin
    Compare := EqualsValue;
    if (FColDataTypes[ACol] = ctString) or (FColDataTypes[ACol] = ctBoolean)
    then
      Result := AnsiCompareText(Value1, Value2)
    else if FColDataTypes[ACol] = ctInteger then
      Result := CompareValue(StrToIntDef(Value1, 0), StrToIntDef(Value2, 0))
    else
    if (FColDataTypes[ACol] = ctDouble)
    or (FColDataTypes[ACol] = ctDate)
    or (FColDataTypes[ACol] = ctTime)
    or (FColDataTypes[ACol] = ctDateTime)
    or (FColDataTypes[ACol] = ctBcd)
    then
      Result := CompareValue(StrToFloatDef(Value1, 0), StrToFloatDef(Value2, 0))
  end;

  procedure Merge(ALow, AMiddle, AHigh: Integer);
  var
    i, j, k, m: Integer;
    LCompareResult: Integer;
  begin
    i := 0;
    SetLength(AVals, AMiddle - ALow + 1);
    for j := ALow to AMiddle do
    begin
      AVals[i] := ARowNoList[j];
      Inc(i);
    end;

    i := 0;
    j := AMiddle + 1;
    k := ALow;
    while (k < j) and (j <= AHigh) do
    begin
      LCompareResult := Compare(Cells[ACol, ARowNoList[j]], Cells[ACol, AVals[i]]);
      if ((ASortMode = smAsc) and (LCompareResult <> LessThanValue)) or
        ((ASortMode = smDesc) and (LCompareResult <> GreaterThanValue))
      then
      begin
        ARowNoList[k] := AVals[i];
        Inc(i);
        Inc(k);
      end
      else
      begin
        ARowNoList[k] := ARowNoList[j];
        Inc(k);
        Inc(j);
      end;
    end;

    for m := k to j - 1 do
    begin
      ARowNoList[m] := AVals[i];
      Inc(i);
    end;
  end;

  procedure PerformSortMerge(ALow, AHigh: Integer);
  var
    AMiddle: Integer;
  begin
    if (ALow < AHigh) then
    begin
      AMiddle := (ALow + AHigh) shr 1;
      PerformSortMerge(ALow, AMiddle);
      PerformSortMerge(AMiddle + 1, AHigh);
      Merge(ALow, AMiddle, AHigh);
    end;
  end;

begin
  if (ASortMode <> smNone) then
    PerformSortMerge(0, High(ARowNoList));
end;

end.
PostgreSQL - Linux - Delphi, Poliüretan
WWW
Cevapla
#6
Koşullu biçimlendirme için şu anda en az bir tane style tanımlı olmalı. Sütun Satır veya hücre için. Daha sonra bu style için koşul yazılıyor.

Ayrıca sort algoritması çok kullanışlı olmadı. Satır sayısı 100000 gibi olunca bayağı yavaş kalıyor. Orada düzeltme iyileştirme şart. Fakat bayağı kullanışlı oldu. Ayrıca sıralama yapılınca yön oku da ekleyeceğim. Sonrasında highlighter
PostgreSQL - Linux - Delphi, Poliüretan
WWW
Cevapla
#7
Sort için hızlandırma yapıldı
Sıralamayı göstermek için fixed row(başlık) rowa küçük oklar eklendi.
Yatay hizalama vardı. Dikey hizalama eklendi. Style özelliğine göre hücre içinde bilgi dikey olarak yukarı aşağı orta ve yata olarak sağ, sol, orta olarak hizalanarak çıkartılıyor.
PostgreSQL - Linux - Delphi, Poliüretan
WWW
Cevapla




Konuyu Okuyanlar: 1 Ziyaretçi