Компонент DBCheckCombox

[SunnyCrash]

Добрый день, столкнулся с такой проблемой в базе есть записи типа 1,2,3,4.. что бы не создавать копии строк тоисть 1 в одной строку 2 в другой строке 3 в третьей ну и так далее возможно ли сделать типа этого компонента буду очень благодарен очень нужно

[SunnyCrash]

Вот нашел его в пасе
unit DBCheckListBox;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, CheckLst, DBCtrls, DB;

type
TDBCheckListBox = class(TCheckListBox)
private
FDataLink: TFieldDataLink;
FValue: integer;
FColsStart: array of integer;
FAutoSizeColumns: boolean;
procedure DataChange(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
procedure SetDataField(const Value: string);
procedure SetDataSource(const Value: TDataSource);
function GetField: TField;
procedure UpdateData(Sender: TObject);
procedure SetValue(const Value: integer);
procedure SetChecked;
procedure SetColsStart(Index: integer; const Value: integer);
function GetColsStart(Index: integer): integer;

procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure UpdateColsStart;
procedure LBSetColWidth(var Message: TMessage); message LB_SETCOLUMNWIDTH;
procedure LBGetItemRect(var Message: TMessage); message LB_GETITEMRECT;
procedure LBSetItemData(var Message: TMessage); message LB_SETITEMDATA;

procedure LBSetCurSel(var Message: TMessage); message LB_SETCURSEL;

procedure SetAutoSizeColumns(const Value: boolean);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure Loaded; override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure SetEnabled(Value: Boolean); override;
procedure KeyPress(var Key: Char); override;
procedure ClickCheck; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Field: TField read GetField;
property ColsStart[Index: integer]: integer read GetColsStart write SetColsStart;
published
property AutoSizeColumns: boolean read FAutoSizeColumns write SetAutoSizeColumns;
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property Value: integer read FValue write SetValue;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Data Controls', [TDBCheckListBox]);
end;

{ TDBCheckListBox }

constructor TDBCheckListBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnUpdateData := UpdateData;
FAutoSizeColumns := false;
end;

destructor TDBCheckListBox.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
// FCanvas.Free;
inherited Destroy;
end;

procedure TDBCheckListBox.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
Style := Style and (not WS_HSCROLL); // убрать нафиг гориз. скроллер
end;

[SunnyCrash]

procedure TDBCheckListBox.Notification(ACompo nent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;

function TDBCheckListBox.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;

procedure TDBCheckListBox.SetDataSource(const Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;

function TDBCheckListBox.GetColsStart(Index: integer): integer;
begin
Result := FColsStart[Index];
end;

function TDBCheckListBox.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;

procedure TDBCheckListBox.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;

function TDBCheckListBox.GetField: TField;
begin
Result := FDataLink.Field;
end;

procedure TDBCheckListBox.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
case Key of
#8, ' ':
FDataLink.Edit;
#27:
FDataLink.Reset;
end;
end;

procedure TDBCheckListBox.LBGetItemRect(var Message: TMessage);
var
iCol, iRow: cardinal;
begin // вызовется, в частности, из родительского ItemAtPos
inherited;
if AutoSizeColumns and (Items.Count > 0) then
begin
iRow := GetListBoxInfo(Self.Handle); // вернёт кол-во строк в колонке
//Message.WParam - индекс выбранного Item
iCol := Message.WParam div iRow; // целочисленное деление обрезает дробную часть, что и требуется
TRect(pointer(Message.LParam)^).Lef t := ColsStart[iCol];
if iCol=(Columns-1) then //последняя колонка
// по-умолчанию правая граница - до границы окна
else
TRect(pointer(Message.LParam)^).Rig ht := ColsStart[iCol+1]-1;
end;
end;

procedure TDBCheckListBox.LBSetColWidth(var Message: TMessage);
begin // сюда попадём после вызова в предке SetColumnWidth - при установке числа колонок
inherited;
UpdateColsStart;
end;

procedure TDBCheckListBox.LBSetCurSel(var Message: TMessage);
begin
inherited;
end;

procedure TDBCheckListBox.LBSetItemData(var Message: TMessage);
begin
inherited;
UpdateColsStart;
end;

procedure TDBCheckListBox.Loaded;
begin
inherited;
UpdateColsStart;
end;

procedure TDBCheckListBox.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Index: Integer;
flag: boolean;
begin
flag := false;
if Button = mbLeft then
begin
Index := ItemAtPos(Point(X,Y),True);
if (Index <> -1) and ItemEnabled[Index] then
begin
flag := true;
Selected[Index] := true;
end;
end;
inherited;
flag := false;
end;

procedure TDBCheckListBox.SetAutoSizeColumns( const Value: boolean);
begin
if Value and (Columns > 0) then
begin
FAutoSizeColumns := Value;
UpdateColsStart;
Invalidate;
end
else
FAutoSizeColumns := false;

end;

[SunnyCrash]

procedure TDBCheckListBox.SetChecked;
var
I: integer;
begin
for I := 0 to Items.Count - 1 do
begin
Checked[I] := ((Value shr I) and 1) = 1;
end;
end;

procedure TDBCheckListBox.SetColsStart(Index: integer;
const Value: integer);
begin
FColsStart[Index] := Value;
end;

procedure TDBCheckListBox.SetValue(const Value: integer);
begin
FValue := Value;
SetChecked;
UpdateColsStart;
end;

procedure TDBCheckListBox.UpdateColsStart;
function GetMaxLength(ACnt, ACol: integer): integer;
var // определим макс длину Items'ов для колонки ACol при кол-ве строк списка ACnt
I, iTW, iLast: integer;
begin
Result := 0;
iLast := ACnt*ACol + ACnt;
if Items.Count>0 then
begin
if Items.Count<iLast then
iLast := Items.Count; // выбрали макс. значение итерации для цикла, меньшее - или конец массива строк или запрошенный диапазон

for I := ACnt*ACol to iLast-1 do
begin
iTW := Canvas.TextWidth(Items[I]);
if iTW > Result then
Result := iTW;
end;
end;
end;
var
iRows: integer;
I: Integer;
begin
if (not AutoSizeColumns) or (Items.Count = 0) then EXIT;
SetLength(FColsStart, Columns); // т.к. начало первой колонки 0
iRows := GetListBoxInfo(Self.Handle);
ColsStart[0] := 0;
for I := 1 to Columns - 1{!!!} do // т.к. начало первой колонки 0
begin
ColsStart[I] := ColsStart[I-1] + GetMaxLength(iRows, I-1) + GetCheckWidth + 5; //сложить с предыдущим
end;
end;

procedure TDBCheckListBox.UpdateData(Sender: TObject);
begin
if FDataLink.Field <> nil then
FDataLink.Field.AsInteger := Value;
end;

procedure TDBCheckListBox.WMSize(var Message: TWMSize);
begin
inherited;
end;

procedure TDBCheckListBox.DataChange(Sender: TObject);
begin
if FDatalink.Field <> nil then
begin
if Value <> FDataLink.Field.AsInteger then
Value := FDataLink.Field.AsInteger;
end
else
Value := 0;
end;

procedure TDBCheckListBox.ClickCheck;
var
I: integer;
begin
FValue := 0;
for I := 0 to Items.Count - 1 do
begin
if Checked[I] then FValue := FValue or (1 shl I);
end;

if FDataLink.Edit then // попытаться войти в редактирование
begin
FDataLink.Modified;
FDataLink.Field.AsInteger := Value;
end;

inherited ClickCheck;
Invalidate;
end;

procedure TDBCheckListBox.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
ItemIndex := -1;
except
SetFocus;
raise;
end;
inherited;
end;

procedure TDBCheckListBox.SetEnabled(Value: Boolean);
begin
if Value then
Font.Color := clBlack
else
Font.Color := clGray;
inherited;
end;

procedure TDBCheckListBox.CNCommand(var Message: TWMCommand);
begin
if (Message.NotifyCode = BN_CLICKED) then
begin
FDataLink.Edit;
if not FDataLink.Editing then Exit;
end;
inherited;
end;

procedure TDBCheckListBox.CNDrawItem(var Message: TWMDrawItem);
var
iCol: cardinal;
begin
if AutoSizeColumns and (Items.Count <> 0) then
begin
with Message.DrawItemStruct^ do
begin
iCol := itemID div GetListBoxInfo(Self.Handle); // целочисленное деление обрезает дробную часть, что и требуется
rcItem.Left := ColsStart[iCol];
if iCol<(Columns-1) then
rcItem.Right := ColsStart[iCol+1]-1;
end;
end;
inherited;
end;

end.
это все может кто то поможет

[SunnyCrash]

Может есть хоть какаято альтернатива?

[SunnyCrash]

такое чувство будто все вымерли...

[Аватар]

Добрый день, столкнулся с такой проблемой в базе есть записи типа 1,2,3,4.. что бы не создавать копии строк тоисть 1 в одной строку 2 в другой строке 3 в третьей ну и так далее возможно ли сделать типа этого компонента буду очень благодарен очень нужно

А можно перевести это на понятный язык? Относительно компонента на картинке - сделать возможно.

такое чувство будто все вымерли

Вас просто никто не понял

[KoliyR]

Есть текстовый тип, числовой
А вот есть еще тип счетчика - который сам считает ...

[KoliyR]

Если требуется пронумеровать строки результата запроса, то через Calculate.
На память точно не помню
QTable.FieldByName('поле calc'):=QTable.RecNo

[SunnyCrash]

Хорошо обьясню, этот компонент похож на CheckListBox1 со вкладки Additional только в чем проблема, сам он мне не нужен а нужен на подобии того что в архиве для работы с БД, что бы я мог отметить мне нужное. А в строке БД была припустим такая строка 1,2,3,4...