unit ValEdit; {$mode objfpc}{$H+} interface uses SysUtils, Classes, Contnrs, Variants, Controls, StdCtrls, Grids, LResources, Dialogs, LCLType, LCLStrConsts, Laz2_XMLCfg; type TValueListEditor = class; // Forward declaration TValueListStrings = class; TEditStyle = (esSimple, esEllipsis, esPickList); TVleSortCol = (colKey, colValue); { TItemProp } TItemProp = class(TPersistent) private FGrid: TValueListEditor; FEditMask: string; FEditStyle: TEditStyle; FPickList: TStrings; FMaxLength: Integer; FReadOnly: Boolean; FKeyDesc: string; function GetPickList: TStrings; procedure PickListChange(Sender: TObject); procedure SetEditMask(const AValue: string); procedure SetMaxLength(const AValue: Integer); procedure SetReadOnly(const AValue: Boolean); procedure SetEditStyle(const AValue: TEditStyle); procedure SetPickList(const AValue: TStrings); procedure SetKeyDesc(const AValue: string); protected procedure AssignTo(Dest: TPersistent); override; public constructor Create(AOwner: TValueListEditor); destructor Destroy; override; // function HasPickList: Boolean; published property EditMask: string read FEditMask write SetEditMask; property EditStyle: TEditStyle read FEditStyle write SetEditStyle; property KeyDesc: string read FKeyDesc write SetKeyDesc; property PickList: TStrings read GetPickList write SetPickList; property MaxLength: Integer read FMaxLength write SetMaxLength; property ReadOnly: Boolean read FReadOnly write SetReadOnly; end; { TItemPropList } TItemPropList = class private FList: TFPObjectList; FStrings: TValueListStrings; function GetCount: Integer; function GetItem(Index: Integer): TItemProp; procedure SetItem(Index: Integer; AValue: TItemProp); protected public procedure Add(AValue: TItemProp); procedure Assign(Source: TItemPropList); procedure Clear; procedure Delete(Index: Integer); procedure Exchange(Index1, Index2: Integer); procedure Insert(Index: Integer; AValue: TItemProp); public constructor Create(AOwner: TValueListStrings); destructor Destroy; override; public property Count: Integer read GetCount; property Items[Index: Integer]: TItemProp read GetItem write SetItem; default; end; { TValueListStrings } TValueListStrings = class(TStringList) private FGrid: TValueListEditor; FItemProps: TItemPropList; function GetItemProp(const AKeyOrIndex: Variant): TItemProp; procedure QuickSortStringsAndItemProps(L, R: Integer; CompareFn: TStringListSortCompare); function CanHideShowingEditorAtIndex(Index: Integer): Boolean; protected procedure InsertItem(Index: Integer; const S: string; AObject: TObject); override; procedure InsertItem(Index: Integer; const S: string); override; procedure Put(Index: Integer; const S: String); override; public constructor Create(AOwner: TValueListEditor); destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Clear; override; procedure CustomSort(Compare: TStringListSortCompare); override; procedure Delete(Index: Integer); override; procedure Exchange(Index1, Index2: Integer); override; end; TKeyValuePair = record Key, Value: String; end; TDisplayOption = (doColumnTitles, doAutoColResize, doKeyColFixed); TDisplayOptions = set of TDisplayOption; TKeyOption = (keyEdit, keyAdd, keyDelete, keyUnique); TKeyOptions = set of TKeyOption; TGetPickListEvent = procedure(Sender: TObject; const KeyName: string; Values: TStrings) of object; TOnValidateEvent = procedure(Sender: TObject; ACol, ARow: Longint; const KeyName, KeyValue: string) of object; { TValueListEditor } TValueListEditor = class(TCustomStringGrid) private FTitleCaptions: TStrings; FCreating: Boolean; FStrings: TValueListStrings; FKeyOptions: TKeyOptions; FDisplayOptions: TDisplayOptions; FDropDownRows: Integer; FOnGetPickList: TGetPickListEvent; FOnStringsChange: TNotifyEvent; FOnStringsChanging: TNotifyEvent; FOnValidate: TOnValidateEvent; FRowTextOnEnter: TKeyValuePair; FLastEditedRow: Integer; FUpdatingKeyOptions: Boolean; function GetItemProp(const AKeyOrIndex: Variant): TItemProp; procedure SetItemProp(const AKeyOrIndex: Variant; AValue: TItemProp); procedure StringsChange(Sender: TObject); procedure StringsChanging(Sender: TObject); function GetOptions: TGridOptions; function GetKey(Index: Integer): string; function GetValue(const Key: string): string; procedure SetDisplayOptions(const AValue: TDisplayOptions); procedure SetDropDownRows(const AValue: Integer); procedure SetKeyOptions(AValue: TKeyOptions); procedure SetKey(Index: Integer; const Value: string); procedure SetValue(const Key: string; AValue: string); procedure SetOptions(AValue: TGridOptions); procedure SetStrings(const AValue: TValueListStrings); procedure SetTitleCaptions(const AValue: TStrings); procedure UpdateTitleCaptions(const KeyCap, ValCap: String); protected class procedure WSRegisterClass; override; procedure SetFixedCols(const AValue: Integer); override; procedure ShowColumnTitles; procedure AdjustRowCount; virtual; procedure ColRowExchanged(IsColumn: Boolean; index, WithIndex: Integer); override; procedure ColRowDeleted(IsColumn: Boolean; index: Integer); override; procedure DefineCellsProperty(Filer: TFiler); override; procedure InvalidateCachedRow; procedure GetAutoFillColumnInfo(const Index: Integer; var aMin,aMax,aPriority: Integer); override; function GetEditText(ACol, ARow: Integer): string; override; function GetCells(ACol, ARow: Integer): string; override; function GetDefaultEditor(Column: Integer): TWinControl; override; function GetRowCount: Integer; procedure KeyDown(var Key : Word; Shift : TShiftState); override; procedure KeyPress(var Key: Char); override; procedure LoadContent(cfg: TXMLConfig; Version: Integer); override; procedure ResetDefaultColWidths; override; procedure SaveContent(cfg: TXMLConfig); override; procedure SetCells(ACol, ARow: Integer; const AValue: string); override; procedure SetColCount(AValue: Integer); override; procedure SetEditText(ACol, ARow: Longint; const Value: string); override; procedure SetFixedRows(const AValue: Integer); override; procedure SetRowCount(AValue: Integer); procedure Sort(ColSorting: Boolean; index,IndxFrom,IndxTo:Integer); override; procedure TitlesChanged(Sender: TObject); function ValidateEntry(const ACol,ARow:Integer; const OldValue:string; var NewValue:string): boolean; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Clear; procedure DeleteColRow(IsColumn: Boolean; index: Integer); procedure DeleteRow(Index: Integer); override; procedure DeleteCol(Index: Integer); override; function FindRow(const KeyName: string; out aRow: Integer): Boolean; procedure InsertColRow(IsColumn: boolean; index: integer); function InsertRow(const KeyName, Value: string; Append: Boolean): Integer; procedure InsertRowWithValues(Index: Integer; Values: array of String); procedure ExchangeColRow(IsColumn: Boolean; index, WithIndex: Integer); override; function IsEmptyRow: Boolean; {Delphi compatible function} function IsEmptyRow(aRow: Integer): Boolean; {This for makes more sense to me} procedure LoadFromCSVStream(AStream: TStream; ADelimiter: Char=','; UseTitles: boolean=true; FromLine: Integer=0; SkipEmptyLines: Boolean=true); override; procedure MoveColRow(IsColumn: Boolean; FromIndex, ToIndex: Integer); function RestoreCurrentRow: Boolean; procedure Sort(Index, IndxFrom, IndxTo: Integer); procedure Sort(ACol: TVleSortCol = colKey); property Modified; property Keys[Index: Integer]: string read GetKey write SetKey; property Values[const Key: string]: string read GetValue write SetValue; property ItemProps[const AKeyOrIndex: Variant]: TItemProp read GetItemProp write SetItemProp; published // Same as in TStringGrid property Align; property AlternateColor; property Anchors; property AutoAdvance; property AutoEdit; property BiDiMode; property BorderSpacing; property BorderStyle; property Color; property Constraints; property DefaultColWidth; property DefaultDrawing; property DefaultRowHeight; property DragCursor; property DragKind; property DragMode; property Enabled; property ExtendedSelect; property FixedColor; property FixedCols; property Flat; property Font; property GridLineWidth; property HeaderHotZones; property HeaderPushZones; property MouseWheelOption; property ParentBiDiMode; property ParentColor default false; property ParentFont; property ParentShowHint; property PopupMenu; property RowCount: Integer read GetRowCount write SetRowCount; property ScrollBars; property ShowHint; property TabOrder; property TabStop; property TitleFont; property TitleImageList; property TitleStyle; property UseXORFeatures; property Visible; property VisibleColCount; property VisibleRowCount; property OnBeforeSelection; property OnButtonClick; property OnChangeBounds; property OnCheckboxToggled; property OnClick; property OnColRowDeleted; property OnColRowExchanged; property OnColRowInserted; property OnColRowMoved; property OnCompareCells; property OnContextPopup; property OnDragDrop; property OnDragOver; property OnDblClick; property OnDrawCell; property OnEditButtonClick; deprecated; property OnEditingDone; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnGetEditMask; property OnGetEditText; property OnHeaderClick; property OnHeaderSized; property OnHeaderSizing; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnMouseWheelHorz; property OnMouseWheelLeft; property OnMouseWheelRight; property OnPickListSelect; property OnPrepareCanvas; property OnResize; property OnSelectEditor; property OnSelection; property OnSelectCell; property OnSetEditText; property OnShowHint; property OnStartDock; property OnStartDrag; property OnTopLeftChanged; property OnUserCheckboxBitmap; property OnUTF8KeyPress; property OnValidateEntry; // Compatible with Delphi TValueListEditor: property DisplayOptions: TDisplayOptions read FDisplayOptions write SetDisplayOptions default [doColumnTitles, doAutoColResize, doKeyColFixed]; property DoubleBuffered; property DropDownRows: Integer read FDropDownRows write SetDropDownRows default 8; property KeyOptions: TKeyOptions read FKeyOptions write SetKeyOptions default []; property Options: TGridOptions read GetOptions write SetOptions default [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goColSizing, goEditing, goAlwaysShowEditor, goThumbTracking]; property Strings: TValueListStrings read FStrings write SetStrings; property TitleCaptions: TStrings read FTitleCaptions write SetTitleCaptions; property OnGetPickList: TGetPickListEvent read FOnGetPickList write FOnGetPickList; property OnStringsChange: TNotifyEvent read FOnStringsChange write FOnStringsChange; property OnStringsChanging: TNotifyEvent read FOnStringsChanging write FOnStringsChanging; property OnValidate: TOnValidateEvent read FOnValidate write FOnValidate; end; const //ToDo: Make this a resourcestring in lclstrconsts unit, once we are satisfied with the implementation of validating rsVLEDuplicateKey = 'Duplicate Key:'+LineEnding+'A key with name "%s" already exists at column %d'; //ToDo: Make this a resourcestring in lclstrconsts unit, once we are satisfied with ShowColumnTitles rsVLEKey = 'Key'; rsVLEValue = 'Value'; rsVLEInvalidRowColOperation = 'The operation %s is not allowed on a TValueListEditor%s.'; //LoadContent errors rsVLENoRowCountFound = 'Error reading file "%s":'^m'No value for RowCount found.'; rsVLERowIndexOutOfBounds = 'Error reading file "%s":'^m'Row index out of bounds (%d).'; rsVLEColIndexOutOfBounds = 'Error reading file "%s":'^m'Column index out of bounds (%d).'; rsVLEIllegalColCount = 'ColCount of a TValueListEditor cannot be %d (it can only ever be 2).'; procedure Register; implementation type TCompositeCellEditorAccess = class(TCompositeCellEditor); { TItemProp } constructor TItemProp.Create(AOwner: TValueListEditor); begin inherited Create; FGrid := AOwner; end; destructor TItemProp.Destroy; begin FPickList.Free; inherited Destroy; end; function TItemProp.GetPickList: TStrings; begin if FPickList = Nil then begin FPickList := TStringList.Create; TStringList(FPickList).OnChange := @PickListChange; end; Result := FPickList; end; procedure TItemProp.PickListChange(Sender: TObject); begin if PickList.Count > 0 then begin if EditStyle = esSimple then EditStyle := esPickList; end else begin if EditStyle = esPickList then EditStyle := esSimple; end; end; procedure TItemProp.SetEditMask(const AValue: string); begin FEditMask := AValue; with FGrid do if EditorMode and (FStrings.UpdateCount = 0) then InvalidateCell(Col, Row); end; procedure TItemProp.SetMaxLength(const AValue: Integer); begin FMaxLength := AValue; with FGrid do if EditorMode and (FStrings.UpdateCount = 0) then InvalidateCell(Col, Row); end; procedure TItemProp.SetReadOnly(const AValue: Boolean); begin FReadOnly := AValue; with FGrid do if EditorMode and (FStrings.UpdateCount = 0) then InvalidateCell(Col, Row); end; procedure TItemProp.SetEditStyle(const AValue: TEditStyle); begin FEditStyle := AValue; with FGrid do if EditorMode and (FStrings.UpdateCount = 0) then InvalidateCell(Col, Row); end; procedure TItemProp.SetPickList(const AValue: TStrings); begin GetPickList.Assign(AValue); with FGrid do if EditorMode and (FStrings.UpdateCount = 0) then InvalidateCell(Col, Row); end; procedure TItemProp.SetKeyDesc(const AValue: string); begin FKeyDesc := AValue; end; procedure TItemProp.AssignTo(Dest: TPersistent); begin if not (Dest is TItemProp) then inherited AssignTo(Dest) else begin TItemProp(Dest).EditMask := Self.EditMask; TItemProp(Dest).EditStyle := Self.EditStyle; TItemProp(Dest).KeyDesc := Self.KeyDesc; TItemProp(Dest).PickList.Assign(Self.PickList); TItemProp(Dest).MaxLength := Self.MaxLength; TItemProp(Dest).ReadOnly := Self.ReadOnly; end; end; { TItemPropList } function TItemPropList.GetItem(Index: Integer): TItemProp; begin Result := TItemProp(FList.Items[Index]); end; function TItemPropList.GetCount: Integer; begin Result := FList.Count; end; procedure TItemPropList.SetItem(Index: Integer; AValue: TItemProp); begin FList.Items[Index] := AValue; end; procedure TItemPropList.Insert(Index: Integer; AValue: TItemProp); begin FList.Insert(Index, AValue); end; procedure TItemPropList.Add(AValue: TItemProp); begin FList.Add(AValue); end; procedure TItemPropList.Assign(Source: TItemPropList); var Index: Integer; Prop: TItemProp; begin Clear; if not Assigned(Source) then Exit; for Index := 0 to Source.Count - 1 do begin Prop := TItemProp.Create(FStrings.FGrid); Prop.Assign(Source.Items[Index]); Add(Prop); end; end; procedure TItemPropList.Delete(Index: Integer); begin FList.Delete(Index); end; procedure TItemPropList.Exchange(Index1, Index2: Integer); begin FList.Exchange(Index1, index2); end; procedure TItemPropList.Clear; begin FList.Clear; end; constructor TItemPropList.Create(AOwner: TValueListStrings); begin FStrings := AOwner; FList := TFPObjectList.Create(True); end; destructor TItemPropList.Destroy; begin FList.Free; inherited Destroy; end; { TValueListStrings } procedure TValueListStrings.InsertItem(Index: Integer; const S: string; AObject: TObject); var MustHideShowingEditor: Boolean; begin // ToDo: Check validity of key //debugln('TValueListStrings.InsertItem: Index = ',dbgs(index),' S = "',S,'" AObject = ',dbgs(aobject)); FGrid.InvalidateCachedRow; MustHideShowingEditor := CanHideShowingEditorAtIndex(Index); if MustHideShowingEditor then FGrid.Options := FGrid.Options - [goAlwaysShowEditor]; inherited InsertItem(Index, S, AObject); FItemProps.Insert(Index, TItemProp.Create(FGrid)); //only restore this _after_ FItemProps is updated! if MustHideShowingEditor then FGrid.Options := FGrid.Options + [goAlwaysShowEditor]; end; procedure TValueListStrings.InsertItem(Index: Integer; const S: string); begin InsertItem(Index, S, nil); end; procedure TValueListStrings.Put(Index: Integer; const S: String); var MustHideShowingEditor: Boolean; begin // ToDo: Check validity of key MustHideShowingEditor := CanHideShowingEditorAtIndex(Index); //debugln('TValueListStrings.Put: MustHideShowingEditor=',DbgS(MustHideShowingEditor)); if MustHideShowingEditor then FGrid.Options := FGrid.Options - [goAlwaysShowEditor]; inherited Put(Index, S); if MustHideShowingEditor then FGrid.Options := FGrid.Options + [goAlwaysShowEditor]; end; constructor TValueListStrings.Create(AOwner: TValueListEditor); begin inherited Create; FGrid := AOwner; FItemProps := TItemPropList.Create(Self); end; destructor TValueListStrings.Destroy; begin FItemProps.Free; inherited Destroy; end; procedure TValueListStrings.Assign(Source: TPersistent); begin FGrid.InvalidateCachedRow; Clear; //if this is not done, and a TValueListEditor.Sort() is done and then later a Strings.Assign, an exception will occur. inherited Assign(Source); if (Source is TValueListStrings) then FItemProps.Assign(TValueListStrings(Source).FItemProps); end; procedure TValueListStrings.Clear; var IsShowingEditor: Boolean; begin FGrid.InvalidateCachedRow; IsShowingEditor := goAlwaysShowEditor in FGrid.Options; if IsShowingEditor then FGrid.Options := FGrid.Options - [goAlwaysShowEditor]; inherited Clear; FItemProps.Clear; if IsShowingEditor then FGrid.Options := FGrid.Options + [goAlwaysShowEditor]; end; { Duplicates the functionality of TStringList.QuickSort, but also sorts the ItemProps. } procedure TValueListStrings.QuickSortStringsAndItemProps(L, R: Integer; CompareFn: TStringListSortCompare); var Pivot, vL, vR: Integer; begin if R - L <= 1 then begin // a little bit of time saver if L < R then if CompareFn(Self, L, R) > 0 then //Exchange also exchanges FItemProps Exchange(L, R); Exit; end; vL := L; vR := R; Pivot := L + Random(R - L); // they say random is best while vL < vR do begin while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do Inc(vL); while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do Dec(vR); //Exchange also exchanges FItemProps Exchange(vL, vR); if Pivot = vL then // swap pivot if we just hit it from one side Pivot := vR else if Pivot = vR then Pivot := vL; end; if Pivot - 1 >= L then QuickSortStringsAndItemProps(L, Pivot - 1, CompareFn); if Pivot + 1 <= R then QuickSortStringsAndItemProps(Pivot + 1, R, CompareFn); end; function TValueListStrings.CanHideShowingEditorAtIndex(Index: Integer): Boolean; var IndexToRow: Integer; WC: TWinControl; EditorHasFocus: Boolean; begin IndexToRow := Index + FGrid.FixedRows; if (FGrid.Editor is TCompositeCellEditor) then begin WC := TCompositeCellEditorAccess(FGrid.Editor).GetActiveControl; if (WC is TCustomEdit) then EditorHasFocus := TCustomEdit(WC).Focused else EditorHasFocus := False; end else EditorHasFocus := Assigned(FGrid.Editor) and FGrid.Editor.Focused; //debugln('CanHideShowingEditor:'); //debugln(' Assigned(FGrid.Editor) = ',DbgS(Assigned(FGrid.Editor))); //debugln(' (goAlwaysShowEditor in FGrid.Options) = ',DbgS(goAlwaysShowEditor in FGrid.Options)); //if Assigned(FGrid.Editor) then // debugln(' FGrid.Editor.Visible = ',DbgS(FGrid.Editor.Visible)); //debugln(' IndexToRow = ',DbgS(IndextoRow)); //debugln(' Count = ',DbgS(Count)); //debugln(' EditorHasFocus = ',DbgS(EditorHasFocus)); Result := Assigned(FGrid.Editor) and (goAlwaysShowEditor in FGrid.Options) and FGrid.Editor.Visible and ((IndexToRow = FGrid.Row) or (Count = 0)) and //if Count = 0 we still have an editable row //if editor is Focussed, we are editing a cell, so we cannot hide! (not EditorHasFocus); //debugln('CanHideShowingEditor: Result = ',DbgS(Result)); end; procedure TValueListStrings.CustomSort(Compare: TStringListSortCompare); { Re-implement it, because we need it to call our own QuickSortStringsAndItemProps and so we cannot use inherited CustomSort Use BeginUpdate/EndUpdate to avoid numerous Changing/Changed calls } begin If not Sorted and (Count>1) then begin try BeginUpdate; FGrid.InvalidateCachedRow; QuickSortStringsAndItemProps(0,Count-1, Compare); finally EndUpdate; end; end; end; procedure TValueListStrings.Delete(Index: Integer); var IsShowingEditor: Boolean; begin FGrid.InvalidateCachedRow; IsShowingEditor := CanHideShowingEditorAtIndex(Index); if IsShowingEditor then FGrid.Options := FGrid.Options - [goAlwaysShowEditor]; inherited Delete(Index); // Delete also ItemProps FItemProps.Delete(Index); //only restore this _after_ FItemProps is updated! if IsShowingEditor then FGrid.Options := FGrid.Options + [goAlwaysShowEditor]; end; procedure TValueListStrings.Exchange(Index1, Index2: Integer); var MustHideShowingEditor: Boolean; begin FGrid.InvalidateCachedRow; MustHideShowingEditor := CanHideShowingEditorAtIndex(Index1) or CanHideShowingEditorAtIndex(Index2); if MustHideShowingEditor then FGrid.Options := FGrid.Options - [goAlwaysShowEditor]; inherited Exchange(Index1, Index2); FItemProps.Exchange(Index1, Index2); if MustHideShowingEditor then FGrid.Options := FGrid.Options + [goAlwaysShowEditor]; end; function TValueListStrings.GetItemProp(const AKeyOrIndex: Variant): TItemProp; var i: Integer; s: string; begin Result := Nil; if (Count > 0) and (UpdateCount = 0) then begin if VarIsOrdinal(AKeyOrIndex) then i := AKeyOrIndex else begin s := AKeyOrIndex; i := IndexOfName(s); if i = -1 then raise Exception.Create('TValueListStrings.GetItemProp: Key not found: '+s); end; if i < FItemProps.Count then begin Result := FItemProps.Items[i]; if not Assigned(Result) then Raise Exception.Create(Format('TValueListStrings.GetItemProp: Index=%d Result=Nil',[i])); end; end; end; { TValueListEditor } constructor TValueListEditor.Create(AOwner: TComponent); begin //need FStrings before inherited Create, because they are needed in overridden SelectEditor FCreating := True; FStrings := TValueListStrings.Create(Self); FStrings.NameValueSeparator := '='; FTitleCaptions := TStringList.Create; inherited Create(AOwner); FStrings.OnChange := @StringsChange; FStrings.OnChanging := @StringsChanging; TStringList(FTitleCaptions).OnChange := @TitlesChanged; //Don't use Columns.Add, it interferes with setting FixedCols := 1 (it will then insert an extra column) { with Columns.Add do Title.Caption := 'Key'; with Columns.Add do begin Title.Caption := 'Value'; DropDownRows := 8; end; } ColCount:=2; {inherited} RowCount := 2; FixedCols := 0; // DefaultColWidth := 150; // DefaultRowHeight := 18; // Width := 306; // Height := 300; Options := [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goColSizing, goEditing, goAlwaysShowEditor, goThumbTracking]; FDisplayOptions := [doColumnTitles, doAutoColResize, doKeyColFixed]; Col := 1; FLastEditedRow := -1; FDropDownRows := 8; ShowColumnTitles; AutoFillColumns := true; FCreating := False; end; destructor TValueListEditor.Destroy; begin FTitleCaptions.Free; FStrings.Free; inherited Destroy; end; procedure TValueListEditor.Clear; begin Strings.Clear; end; procedure TValueListEditor.DeleteColRow(IsColumn: Boolean; index: Integer); begin if not IsColumn then DeleteRow(Index) else DeleteCol(Index); end; procedure TValueListEditor.DeleteRow(Index: Integer); begin //If we have only one row, it may be empty and we cannot remove if not ((Index - FixedRows = 0) and (Strings.Count = 0)) then inherited DeleteRow(Index) ; end; procedure TValueListEditor.DeleteCol(Index: Integer); begin Raise EGridException.CreateFmt(rsVLEInvalidRowColOperation,['DeleteCol','']); end; function TValueListEditor.FindRow(const KeyName: string; out aRow: Integer): Boolean; var Index: Integer; begin Index := Strings.IndexOfName(KeyName); Result := (Index > -1); if Result then aRow := Index + FixedRows; end; procedure TValueListEditor.InsertColRow(IsColumn: boolean; index: integer); begin if not IsColumn then Strings.InsertItem(Index - FixedRows,'') else Raise EGridException.CreateFmt(rsVLEInvalidRowColOperation,['InsertColRow',' on columns']); end; function TValueListEditor.InsertRow(const KeyName, Value: string; Append: Boolean): Integer; var NewInd, NewRow: Integer; Line: String; begin if not ((KeyName = '') and (Value = '')) then Line := KeyName + Strings.NameValueSeparator + Value else Line := ''; if (Row > Strings.Count) or ((Row - FixedRows) >= Strings.Count) or (Cells[0, Row] <> '') or (Cells[1, Row] <> '') then begin // Add a new Key=Value pair Strings.BeginUpdate; try if Append then begin if (Strings.Count = 0) then //empty grid NewInd := 0 else NewInd := Row - FixedRows + 1 //append after current row end else NewInd := Row - FixedRows; //insert it at current row Strings.InsertItem(NewInd, Line, Nil); finally Strings.EndUpdate; end; end else begin // Use an existing row, just update the Key and Value. Cells[0, Row] := KeyName; Cells[1, Row] := Value; NewInd := Row - FixedRows; end; Result := NewInd; NewRow := NewInd + FixedRows; if (NewRow <> Row) then Row := NewRow; end; procedure TValueListEditor.InsertRowWithValues(Index: Integer; Values: array of String); var AKey, AValue: String; begin AKey := ''; AValue := ''; if (Length(Values) > 1) then begin AKey := Values[0]; AValue := Values[1]; end else if (Length(Values) = 1) then AKey := Values[0]; Strings.InsertItem(Index, AKey + Strings.NameValueSeparator + AValue); end; procedure TValueListEditor.ExchangeColRow(IsColumn: Boolean; index, WithIndex: Integer); begin if not IsColumn then inherited ExchangeColRow(IsColumn, index, WithIndex) else Raise EGridException.CreateFmt(rsVLEInvalidRowColOperation,['ExchangeColRow',' on columns']); end; function TValueListEditor.IsEmptyRow: Boolean; {As per help text on Embarcadero: the function does not have a parameter for row, so assume current one?} begin Result := IsEmptyRow(Row); end; function TValueListEditor.IsEmptyRow(aRow: Integer): Boolean; begin if (Strings.Count = 0) and (aRow - FixedRows = 0) then //special case: we have just one row, and it is empty Result := True else if (aRow = 0) and (FixedRows = 0) then Result := ((inherited GetCells(0,0)) = EmptyStr) and ((inherited GetCells(1,0)) = EmptyStr) else Result := Strings.Strings[aRow - FixedRows] = EmptyStr; end; procedure TValueListEditor.LoadFromCSVStream(AStream: TStream; ADelimiter: Char; UseTitles: boolean; FromLine: Integer; SkipEmptyLines: Boolean); begin inherited LoadFromCSVStream(AStream, ADelimiter, UseTitles, FromLine, SkipEmptyLines); if UseTitles then UpdateTitleCaptions(Cells[0,0],Cells[1,0]); end; procedure TValueListEditor.MoveColRow(IsColumn: Boolean; FromIndex, ToIndex: Integer); var Line: String; begin if not IsColumn then begin try Strings.BeginUpdate; Line := Strings.Strings[FromIndex - FixedRows]; Strings.Delete(FromIndex - FixedRows); Strings.InsertItem(ToIndex - FixedRows, Line); finally Strings.EndUpdate; end; end else Raise EGridException.CreateFmt(rsVLEInvalidRowColOperation,['MoveColRow',' on columns']); end; function TValueListEditor.RestoreCurrentRow: Boolean; begin //DbgOut('RestoreCurrentRow: Row=',DbgS(Row),' FLastEditedRow=',DbgS(FLastEditedRow),' SavedKey=',FRowTextOnEnter.Key,' SavedValue=',FRowTextOnEnter.Value); Result := False; if (Row = FLastEditedRow) and Assigned(Editor) and Editor.Focused then begin if (Cells[0,Row] <> FRowTextOnEnter.Key) or (Cells[1,Row] <> FRowTextOnEnter.Value) then begin try EditorHide; if (Cells[0,Row] <> FRowTextOnEnter.Key) then Cells[0,Row] := FRowTextOnEnter.Key; if (Cells[1,Row] <> FRowTextOnEnter.Value) then Cells[1,Row] := FRowTextOnEnter.Value; finally EditorShow(True); end; Result := True; end; end; end; procedure TValueListEditor.Sort(ACol: TVleSortCol = colKey); begin SortColRow(True, Ord(ACol)); end; procedure TValueListEditor.Sort(Index, IndxFrom, IndxTo: Integer); begin Sort(True, Index, IndxFrom, IndxTo); end; procedure TValueListEditor.StringsChange(Sender: TObject); begin Modified := True; AdjustRowCount; Invalidate; if Assigned(OnStringsChange) then OnStringsChange(Self); end; procedure TValueListEditor.StringsChanging(Sender: TObject); begin if Assigned(OnStringsChanging) then OnStringsChanging(Self); end; procedure TValueListEditor.SetFixedCols(const AValue: Integer); begin if (AValue in [0,1]) then inherited SetFixedCols(AValue); end; procedure TValueListEditor.SetFixedRows(const AValue: Integer); begin if AValue in [0,1] then begin // No other values are allowed if AValue = 0 then // Typically DisplayOptions are changed directly DisplayOptions := DisplayOptions - [doColumnTitles] else DisplayOptions := DisplayOptions + [doColumnTitles] end; end; function TValueListEditor.GetItemProp(const AKeyOrIndex: Variant): TItemProp; begin Result := FStrings.GetItemProp(AKeyOrIndex); end; procedure TValueListEditor.SetItemProp(const AKeyOrIndex: Variant; AValue: TItemProp); begin FStrings.GetItemProp(AKeyOrIndex).Assign(AValue); end; function TValueListEditor.GetOptions: TGridOptions; begin Result := inherited Options; end; procedure TValueListEditor.SetDisplayOptions(const AValue: TDisplayOptions); // Set number of fixed rows to 1 if titles are shown (based on DisplayOptions). // Set the local options value, then Adjust Column Widths and Refresh the display. begin BeginUpdate; if (doColumnTitles in DisplayOptions) <> (doColumnTitles in AValue) then if doColumnTitles in AValue then begin if RowCount < 2 then {inherited} RowCount := 2; inherited SetFixedRows(1);// don't do FixedRows := 1 here, it wil cause infinite recursion (Issue 0029993) end else inherited SetFixedRows(0); if (doAutoColResize in DisplayOptions) <> (doAutoColResize in AValue) then AutoFillColumns := (doAutoColResize in AValue); FDisplayOptions := AValue; ShowColumnTitles; AdjustRowCount; EndUpdate; end; procedure TValueListEditor.SetDropDownRows(const AValue: Integer); begin FDropDownRows := AValue; // ToDo: If edit list for inplace editing is implemented, set its handler, too. end; procedure TValueListEditor.SetKeyOptions(AValue: TKeyOptions); begin FUpdatingKeyOptions := True; // KeyAdd requires KeyEdit, KeyAdd oddly enough does not according to Delphi specs if KeyAdd in AValue then Include(AValue, keyEdit); FKeyOptions := AValue; if (KeyAdd in FKeyOptions) then Options := Options + [goAutoAddRows] else Options := Options - [goAutoAddRows]; FUpdatingKeyOptions := False; end; procedure TValueListEditor.SetOptions(AValue: TGridOptions); begin //cannot allow goColMoving if goColMoving in AValue then Exclude(AValue, goColMoving); //temporarily disable this, it causes crashes if (goAutoAddRowsSkipContentCheck in AValue) then Exclude(AValue, goAutoAddRowsSkipContentCheck); inherited Options := AValue; // Enable also the required KeyOptions for goAutoAddRows if not FUpdatingKeyOptions and not (csLoading in ComponentState) and (goAutoAddRows in AValue) then KeyOptions := KeyOptions + [keyEdit, keyAdd]; end; procedure TValueListEditor.SetStrings(const AValue: TValueListStrings); begin FStrings.Assign(AValue); end; procedure TValueListEditor.SetTitleCaptions(const AValue: TStrings); begin FTitleCaptions.Assign(AValue); end; procedure TValueListEditor.UpdateTitleCaptions(const KeyCap, ValCap: String); begin FTitleCaptions.Clear; FTitleCaptions.Add(KeyCap); FTitleCaptions.Add(ValCap); end; function TValueListEditor.GetKey(Index: Integer): string; begin Result:=Cells[0,Index]; end; procedure TValueListEditor.SetKey(Index: Integer; const Value: string); begin Cells[0,Index]:=Value; end; function TValueListEditor.GetValue(const Key: string): string; var I: Integer; begin Result := ''; I := Strings.IndexOfName(Key); if I > -1 then begin Inc(I, FixedRows); Result:=Cells[1,I]; end; end; procedure TValueListEditor.SetValue(const Key: string; AValue: string); var I: Integer; begin I := Strings.IndexOfName(Key); if I > -1 then begin Inc(I, FixedRows); Cells[1,I]:=AValue; end else begin Insert(Strings.NameValueSeparator, AValue, 1); Insert(Key, AValue, 1); Strings.Add(AValue); end; end; procedure TValueListEditor.ShowColumnTitles; var KeyCap, ValCap: String; begin if (doColumnTitles in DisplayOptions) then begin KeyCap := rsVLEKey; ValCap := rsVLEValue; if (TitleCaptions.Count > 0) then KeyCap := TitleCaptions[0]; if (TitleCaptions.Count > 1) then ValCap := TitleCaptions[1]; //Columns[0].Title.Caption := KeyCap; //Columns[1].Title.Caption := ValCap; //or: Cells[0,0] := KeyCap; Cells[1,0] := ValCap; end; end; procedure TValueListEditor.AdjustRowCount; // Change the number of rows based on the number of items in Strings collection. // Sets Row and RowCount of parent TCustomDrawGrid class. var NewC: Integer; begin NewC:=FixedRows+1; if Strings.Count>0 then NewC:=Strings.Count+FixedRows; if NewC<>RowCount then begin if NewC= Strings.Count) then //Either empty grid, or a row has been added and Strings hasn't been update yet //the latter happens when rows are auto-added (issue #0025166) Exit; if ACol=0 then Result:=Strings.Names[I] else if ACol=1 then Result:=Strings.ValueFromIndex[I]; end; end; procedure SetGridEditorReadOnly(Ed: TwinControl; RO: Boolean); begin //debugln('SetEditorReadOnly: Ed is ',DbgSName(Ed),' ReadOnly=',DbgS(RO)); if (Ed is TCustomEdit) then TCustomEdit(Ed).ReadOnly := RO else if (Ed is TCustomComboBox) then if RO then TCustomComboBox(Ed).Style := csDropDownList else TCustomComboBox(Ed).Style := csDropDown; end; function TValueListEditor.GetDefaultEditor(Column: Integer): TWinControl; var ItemProp: TItemProp; begin if (Row <> FLastEditedRow) then //save current contents for RestoreCurrentRow begin FLastEditedRow := Row; FRowTextOnEnter.Key := Cells[0,Row]; FRowTextOnEnter.Value := Cells[1,Row]; end; Result:=inherited GetDefaultEditor(Column); //Need this to be able to intercept VK_Delete in the editor if (KeyDelete in KeyOptions) then EditorOptions := EditorOptions or EO_HOOKKEYDOWN else EditorOptions := EditorOptions and (not EO_HOOKKEYDOWN); if Column=1 then begin ItemProp := nil; //debugln('**** A Col=',dbgs(col),' Row=',dbgs(row),' (',dbgs(itemprop),')'); ItemProp := Strings.GetItemProp(Row-FixedRows); if Assigned(ItemProp) then begin case ItemProp.EditStyle of esSimple: begin result := EditorByStyle(cbsAuto); SetGridEditorReadOnly(result, ItemProp.ReadOnly); end; esEllipsis: begin result := EditorByStyle(cbsEllipsis); SetGridEditorReadOnly(TCompositeCellEditorAccess(result).GetActiveControl, ItemProp.ReadOnly); end; esPickList: begin result := EditorByStyle(cbsPickList); (result as TCustomComboBox).Items.Assign(ItemProp.PickList); (result as TCustomComboBox).DropDownCount := DropDownRows; SetGridEditorReadOnly(result, ItemProp.ReadOnly); if Assigned(FOnGetPickList) then FOnGetPickList(Self, Strings.Names[Row - FixedRows], (result as TCustomComboBox).Items); //Style := csDropDown, default = csDropDownList; end; end; //case end else SetGridEditorReadOnly(result, False); end else begin //First column is only editable if KeyEdit is in KeyOptions if not (KeyEdit in KeyOptions) then Result := nil else SetGridEditorReadOnly(result, False); end; end; function TValueListEditor.GetRowCount: Integer; begin Result := inherited RowCount; end; procedure TValueListEditor.KeyDown(var Key: Word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); if (KeyAdd in KeyOptions) then begin if (Key = VK_INSERT) and (Shift = []) then begin //Insert a row in the current position InsertRow('', '', False); Key := 0; end; end; if (KeyDelete in KeyOptions) then begin //Although Delphi help says this happens if user presses Delete, testers report it only happens with Ctrl+Delete if (Key = VK_DELETE) and (Shift = [ssModifier]) then begin DeleteRow(Row); Key := 0; end; end; if (Key = VK_ESCAPE) and (Shift = []) then if RestoreCurrentRow then Key := 0; end; procedure TValueListEditor.KeyPress(var Key: Char); begin inherited KeyPress(Key); if (Key = Strings.NameValueSeparator) and (Col = 0) then begin//move to Value column Key := #0; //Modified code from TCustomGrid.KeyDown GridFlags := GridFlags + [gfEditingDone]; if MoveNextSelectable(True, 1, 0) then Click; GridFlags := GridFlags - [gfEditingDone]; end; end; procedure TValueListEditor.LoadContent(cfg: TXMLConfig; Version: Integer); var ContentSaved, HasColumnTitles, AlwaysShowEditor: Boolean; i,j,k, RC: Integer; KeyCap, ValCap, S: String; oldSaveOptions: TSaveOptions; begin // Check that this file is a valid ValueListEditor grid RC := cfg.GetValue('grid/content/rowcount', -1); if (RC = -1) then raise EStreamError.CreateFmt(rsVLENoRowCountFound,[cfg.Filename]); if (RC < 1) then RC := 1; HasColumnTitles := cfg.getValue('grid/content/hascolumntitles', False); //contrary to other grids we restore the entire saved content, //so we add/delete rows (not columns of course) as needed. if HasColumnTitles and (RC = 1) then RC := 2; // Check that cell content makes sense k:=cfg.getValue('grid/content/cells/cellcount', 0); while k>0 do begin i := cfg.GetValue('grid/content/cells/cell'+IntToStr(k)+'/column', -1); j := cfg.GetValue('grid/content/cells/cell'+IntTostr(k)+'/row',-1); if (j<0) or (j>RC-1) then raise EStreamError.CreateFmt(rsVLERowIndexOutOfBounds,[cfg.Filename,j]); if not IsColumnIndexValid(i) then raise EStreamError.CreateFmt(rsVLEColIndexOutOfBounds,[cfg.Filename,i]); Dec(k); end; KeyCap := ''; ValCap := ''; oldSaveOptions := SaveOptions; BeginUpdate; try AlwaysShowEditor := (goAlwaysShowEditor in Options); if AlwaysShowEditor then Options := Options - [goAlwaysShowEditor]; SaveOptions := SaveOptions - [soContent]; inherited LoadContent(Cfg, Version); if soContent in oldSaveOptions then begin ContentSaved:=Cfg.GetValue('grid/saveoptions/content', false); if ContentSaved then begin Clean(0,0,ColCount-1,RowCount-1,[]); //needed if the to be loaded grid has no entries if HasColumnTitles then DisplayOptions := DisplayOptions + [doColumnTitles] else DisplayOptions := DisplayOptions - [doColumnTitles]; RowCount := RC; k:=cfg.getValue('grid/content/cells/cellcount', 0); while k>0 do begin i := cfg.GetValue('grid/content/cells/cell'+IntToStr(k)+'/column', -1); j := cfg.GetValue('grid/content/cells/cell'+IntTostr(k)+'/row',-1); S := cfg.GetValue('grid/content/cells/cell'+IntToStr(k)+'/text',''); Cells[i,j] := S; if HasColumnTitles and (i = 0) and (j = 0) then KeyCap := S else if HasColumnTitles and (i = 1) and (j = 0) then ValCap := S; Dec(k); end; if HasColumnTitles then UpdateTitleCaptions(KeyCap, ValCap); end; end; finally if AlwaysShowEditor then Options := Options + [goAlwaysShowEditor]; SaveOptions := oldSaveOptions; EndUpdate(True); end; end; procedure TValueListEditor.ResetDefaultColWidths; begin if not AutoFillColumns then inherited ResetDefaultColWidths else if doKeyColFixed in DisplayOptions then begin SetRawColWidths(0, -1); VisualChange; end; end; procedure TValueListEditor.SaveContent(cfg: TXMLConfig); var i,j,k: Integer; Value: String; HasSaveContent: Boolean; begin HasSaveContent := soContent in SaveOptions; //no need to save content in inherited SaveContent, since we re-implemented that here. if HasSaveContent then SaveOptions := SaveOptions - [soContent]; try inherited SaveContent(cfg); if HasSaveContent then SaveOptions := SaveOptions + [soContent]; cfg.SetValue('grid/saveoptions/content', soContent in SaveOptions); if soContent in SaveOptions then begin cfg.SetValue('grid/content/hascolumntitles',(doColumnTitles in FDisplayOptions)); cfg.SetValue('grid/content/rowcount', RowCount); // Save Cell Contents k:=0; For i:=0 to ColCount-1 do For j:=0 to RowCount-1 do begin //fGrid.Celda is unassigned for cells other than the title row, so we neet to query GetCells here Value := GetCells(i,j); if (Value <> '') then begin Inc(k); //Cfg.SetValue('grid/content/cells/cellcount',k); cfg.SetValue('grid/content/cells/cell'+IntToStr(k)+'/column',i); cfg.SetValue('grid/content/cells/cell'+IntToStr(k)+'/row',j); cfg.SetValue('grid/content/cells/cell'+IntToStr(k)+'/text', Value); end; Cfg.SetValue('grid/content/cells/cellcount',k); end; end; finally if HasSaveContent then SaveOptions := SaveOptions + [soContent]; end; end; procedure TValueListEditor.SetCells(ACol, ARow: Integer; const AValue: string); var I: Integer; Key, KeyValue, Line: string; Sep: Char; begin if (ARow = 0) and (doColumnTitles in DisplayOptions) then begin Inherited SetCells(ACol, ARow, AValue); end else begin I:=ARow-FixedRows; if ACol=0 then begin Sep := Strings.NameValueSeparator; Key := AValue; { A Key can never contain NameVlaueSeparator (by default an equal sign ('=')) While we disallow typing '=' inside the Key column we cannot prevent the user from pasting text that contains a '=' This leads to strange effects since when we insert the Key/Value pair into the Strings property, in effect the equal sign will be treated (by design) as the separator for the value part. This in turn updates the Value column, but does not remove the equal sign from Key. E.g. if both Key and Value celss are empty and you type '=' into an empty Key cell, the Value cell will become '==' Reported on forum: https://forum.lazarus.freepascal.org/index.php?topic=51977.0;topicseen } if (Pos(Sep, Key) > 0) then begin Key := StringReplace(Key, Sep, '', [rfReplaceAll]); //update the content of the Column cell inherited SetCells(ACol, ARow, Key); end; KeyValue := Cells[1,ARow] end else begin KeyValue := AValue; Key := Cells[0,ARow]; end; //If cells are empty don't store '=' in Strings if (Key = '') and (KeyValue = '') then Line := '' else begin Line := KeyValue; system.Insert(Strings.NameValueSeparator, Line, 1); system.Insert(Key, Line, 1); end; // Empty grid: don't add a the line '' to Strings! if (Strings.Count = 0) and (Line = '') then Exit; if I>=Strings.Count then Strings.Insert(I,Line) else if (Line <> Strings[I]) then Strings[I]:=Line; end; end; procedure TValueListEditor.SetColCount(AValue: Integer); begin if (not FCreating) and (not (csLoading in ComponentState)) and (AValue <> 2) then raise EGridException.CreateFmt(rsVLEIllegalColCount,[AValue]); inherited SetColCount(AValue); end; function TValueListEditor.GetEditText(ACol, ARow: Integer): string; begin Result:= Cells[ACol, ARow]; if Assigned(OnGetEditText) then OnGetEditText(Self, ACol, ARow, Result); end; procedure TValueListEditor.SetEditText(ACol, ARow: Longint; const Value: string); begin inherited SetEditText(ACol, ARow, Value); Cells[ACol, ARow] := Value; end; procedure TValueListEditor.SetRowCount(AValue: Integer); var OldValue, NewCount: Integer; begin //debugln('TValueListEditor.SetRowCount: AValue=',DbgS(AValue)); OldValue := inherited RowCount; if OldValue = AValue then Exit; if FixedRows > AValue then Raise EGridException.Create(rsFixedRowsTooBig); NewCount := AValue - FixedRows; if (NewCount > Strings.Count) then begin Strings.BeginUpdate; while (Strings.Count < NewCount) do Strings.Add(''); Strings.EndUpdate; end else if (NewCount < Strings.Count) then begin Strings.BeginUpdate; while (NewCount < Strings.Count) do Strings.Delete(Strings.Count - 1); Strings.EndUpdate; end; end; procedure TValueListEditor.Sort(ColSorting: Boolean; index, IndxFrom, IndxTo: Integer); var HideEditor: Boolean; begin HideEditor := goAlwaysShowEditor in Options; if HideEditor then Options := Options - [goAlwaysShowEditor]; Strings.BeginUpdate; try inherited Sort(True, index, IndxFrom, IndxTo); finally Strings.EndUpdate; end; if HideEditor then Options := Options + [goAlwaysShowEditor]; end; procedure TValueListEditor.TitlesChanged(Sender: TObject); begin // Refresh the display. ShowColumnTitles; AdjustRowCount; Invalidate; end; function TValueListEditor.ValidateEntry(const ACol, ARow: Integer; const OldValue: string; var NewValue: string): boolean; var Index, i: Integer; begin Result := inherited ValidateEntry(ACol, ARow, OldValue, NewValue); //Check for duplicate key names (only in "Key" column), if KeyUnique is set if ((ACol - FixedCols) = 0) and (KeyUnique in KeyOptions) then begin Index := ARow - FixedRows; for i := 0 to FStrings.Count - 1 do begin if (Index <> i) and (FStrings.Names[i] <> '') then begin if (AnsiCompareText(FStrings.Names[i], NewValue) = 0) then begin Result := False; ShowMessage(Format(rsVLEDuplicateKey,[NewValue, i + FixedRows])); if Editor is TStringCellEditor then TStringCelleditor(Editor).SelectAll; Break; end; end; end; end; end; class procedure TValueListEditor.WSRegisterClass; begin // RegisterPropertyToSkip(Self, 'SomeProperty', 'VCL compatibility property', ''); inherited WSRegisterClass; end; procedure Register; begin RegisterComponents('Additional',[TValueListEditor]); end; end.