Como estaba harto de que este componente me diese problemas con el tema de la negrita, lo he vuelto a modificar y aquí lo dejo ya corregido
Código Delphi
[-]
unit TDbIbchkbox;
interface
uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
Forms, Graphics, Stdctrls, DbTables, DB, DBCtrls, TypInfo, Dialogs;
type
TDBIBCheckbox = class(TCheckBox)
private
FUpperCaseChk : Boolean;
FBoldCheck: Boolean;
FValueChecked : String;
FValueUnChecked : String;
FOnChange : TNotifyEvent;
FDataLink : TFieldDataLink;
FBoldfixed: Boolean;
procedure AutoInitialize;
procedure AutoDestroy;
function GetDataField : String;
procedure SetDataField(Value : String);
function GetDataSource : TDataSource;
procedure SetDataSource(Value : TDataSource);
procedure SetUppercaseChk(value:Boolean);
function GetUpperCaseChk : Boolean;
procedure SetValueChecked(value:string);
procedure SetValueUnChecked(value:string);
procedure ActiveChange(Sender : TObject);
procedure DataChange(Sender : TObject);
procedure EditingChange(Sender : TObject);
procedure UpdateData(Sender : TObject);
procedure SetBoldCheck(Value:Boolean);
procedure SetBoldfixed(Value:Boolean); protected
procedure Change(Sender : TObject); virtual;
procedure Click; override;
procedure KeyPress(var Key : Char); override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnChange : TNotifyEvent read FOnChange write FOnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property DataField : String read GetDataField write SetDataField;
property DataSource : TDataSource read GetDataSource write SetDataSource;
property UpperCaseChk : Boolean read GetUpperCaseChk write SetUppercaseChk default True;
property ValueChecked : String read FValueChecked write SetValueChecked;
property ValueUnChecked : String read FValueUnChecked write SetValueUnChecked;
property BoldCheck:Boolean read FBoldCheck write SetBoldCheck default True;
property Boldfixed:Boolean read FBoldfixed write SetBoldfixed default True;
Procedure DBICHKNOT;
end;
procedure Register;
implementation
Function GetTipoCampo (DataSet :TDataSet; Index :Integer) :String;
Begin
Result := GetEnumName (TypeInfo (TFieldType),
Integer (DataSet.Fields [Index].DataType));
End;
procedure Register;
begin
RegisterComponents('InterBase', [TDBIBCheckbox]);
end;
procedure TDBIBCheckbox.AutoInitialize;
begin
FDataLink := TFieldDataLink.Create;
FBoldCheck:=True;
FUpperCaseChk:=True;
FBoldfixed:=True;
with FDataLink do
begin
OnDataChange := DataChange;
OnUpdateData := UpdateData;
OnEditingChange := EditingChange;
OnActiveChange := ActiveChange;
end;
end;
procedure TDBIBCheckbox.AutoDestroy;
begin
FDataLink.Free;
end;
function TDBIBCheckbox.GetDataField : String;
begin
Result := FDataLink.FieldName;
end;
procedure TDBIBCheckbox.SetDataField(Value : String);
begin
FDataLink.FieldName := Value;
end;
function TDBIBCheckbox.GetDataSource : TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBIBCheckbox.SetDataSource(Value : TDataSource);
begin
FDataLink.DataSource := Value;
end;
function TDBIBCheckbox.GetUpperCasechk : Boolean;
begin
Result := FUpperCaseChk;
end;
procedure TDBIBCheckbox.Change(Sender : TObject);
begin
if Assigned(FOnChange) then FOnChange(Sender);
end;
procedure TDBIBCheckbox.Click;
begin
if FDataLink.Editing then begin
FDataLink.Modified;
if fDataLink.field <> nil then
begin
if (Checked) then
begin
if FUpperCaseChk then fDataLink.field.Value := UPperCase(FValueChecked)
else fDataLink.field.Value := FValueChecked;
if (FBoldCheck) then
begin
if (fBoldfixed=False) then Self.Font.Style:=[fsBold]
else Self.Font.Style:=[];
end;
end else
begin
if FUpperCaseChk=False then fDataLink.field.Value := UpperCase(FValueChecked)
else fDataLink.field.Value := FValueUnChecked;
end;
end;
inherited Click;
end;
end;
procedure TDBIBCheckbox.KeyPress(var Key : Char);
begin
inherited KeyPress(Key);
end;
constructor TDBIBCheckbox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoInitialize;
FUpperCaseChk:=True;
FValueChecked:='SI';
FValueUnChecked:='NO';
end;
procedure TDBIBCheckbox.DataChange(Sender : TObject);
begin
if fDataLink.field <> nil then
begin
if FUpperCaseChk then
begin
if UpperCase(FDataLink.Field.AsString)=UpperCase(FValueChecked) then Checked:=true
else Checked:=False;
end else
begin
if FDataLink.Field.Value=FValueChecked then Checked:=true
else Checked:=False;
end;
if (Checked) then
begin
if (FBoldCheck) then
begin
if (fBoldfixed=False) then Self.Font.Style:=[fsBold]
else Self.Font.Style:=[];
end;
end;
if Assigned(FOnChange) then FOnChange(Sender);
end;
end;
destructor TDBIBCheckbox.Destroy;
begin
AutoDestroy;
inherited Destroy;
end;
procedure TDBIBCheckbox.EditingChange(Sender : TObject);
begin
end;
procedure TDBIBCheckbox.Loaded;
begin
inherited Loaded;
end;
procedure TDBIBCheckbox.ActiveChange(Sender : TObject);
const
IntFieldTypes = [ftSmallInt, ftInteger, ftWord];
begin
if DataField = '' then Exit;
end;
procedure TDBIBCheckbox.UpdateData(Sender : TObject);
begin
if fDataLink.field <> nil then
begin
if (Checked) then
begin
if FUpperCaseChk then fDataLink.field.Value := UPperCase(FValueChecked)
else fDataLink.field.Value := FValueChecked;
if (FBoldCheck) then
begin
if (fBoldfixed=False) then Self.Font.Style:=[fsBold]
else Self.Font.Style:=[];
end;
end else
begin
if FUpperCaseChk=False then fDataLink.field.Value := UpperCase(FValueChecked)
else fDataLink.field.Value := FValueUnChecked;
end;
end;
end;
procedure TDBIBCheckbox.SetUppercaseChk(value: Boolean);
begin
if value<>FUpperCaseChk then FUpperCaseChk:=value;
end;
procedure TDBIBCheckbox.SetValueChecked(value: string);
begin
if value<>FValueChecked then
begin
if FDataLink.Field<>nil then
begin
if Length(value)>FDataLink.Field.Size then ShowMessage('El ValueCheck [ '+Value+' ] contiene más caracteres de los '+#13+#10+
'permitidos, que es de [ '+IntToStr(FDataLink.Field.Size)+' ] caracteres')
else FValueChecked:=value;
end else FValueChecked:=value;
end;
end;
procedure TDBIBCheckbox.SetBoldCheck(Value: Boolean);
begin
if FBoldCheck<>value then FBoldCheck:=Value;
end;
procedure TDBIBCheckbox.SetBoldfixed(Value: Boolean);
begin
if FBoldfixed<>Value then FBoldfixed:=Value;
if FBoldfixed then Self.Font.Style:=[fsBold] else Self.Font.Style:=[]
end;
procedure TDBIBCheckbox.SetValueUnChecked(value: string);
begin
if value<>FValueUnChecked then
begin
if FDataLink.Field<>nil then
begin
if Length(value)>FDataLink.Field.Size then ShowMessage('El ValueUnCheck [ '+Value+' ] contiene más caracteres de los '+#13+#10+
'permitidos, que es de [ '+IntToStr(FDataLink.Field.Size)+' ] caracteres')
else FValueUnChecked:=value;
end else FValueUnChecked:=value;
end;
end;
Procedure TDBIBCheckbox.DBICHKNOT;
begin
if FDataLink.Editing=true then
begin
FDataLink.Field.Value:=FValueUnChecked;
end;
end;
end.