My DBList (alter DBGrid) - prblem with refresh main "Pa
lazarus / 5-Lazarus Extra Components

----------------------------------------------------------------------
mad · 2008-06-26 11:44

This component work incorrectly. I don't know how repair DBList.
i need help.. compile and see how work





unit DBList;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls,
StdCtrls, sqldb, windows, db, DbCtrls, LMessages;

type
DBListView = class(TCustomControl)
private
FGora: TPanel;
FBody: TPanel;
defGora: TPanel;
FCanvas: TCanvas;
pos: integer;
FSelectedColor: TColor;
FNoSelectedColor: TColor;
FScroll: TScrollBar;
defScrool: TScrollBar;
FDatasource: TDatasource;
prevPos: integer;
procedure SetGora(const Value: TPanel);
procedure SetBody(const Value: TPanel);
procedure SetScroll(const Value: TScrollBar);
procedure SetDatasource(const Value: TDatasource);
procedure Rysuj(w, h: integer; c: TCanvas; y: integer);
procedure ChangeBar(Sender: TObject);
procedure NaprawGora();
procedure NaprawBody();
procedure NaprawScroll();
procedure CreateGora;
procedure CreateScroll;
function IsWrongBody: Boolean;
function IsWrongGora: Boolean;
function IsWrongScrool: Boolean;
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure Next();
procedure Prior();
protected
procedure Loaded; override;
procedure PaletteCreated; override;
procedure SetParent(AParent: TWinControl); override;
procedure VCLKeyDown(var Key: Word; Shift: TShiftState); virtual;
procedure Paint; override;
procedure PaintWindow(DC: HDC); override;
public
rys: boolean;
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
function Count(): integer;
published
property Gora:TPanel read FGora write SetGora stored IsWrongGora;
property Body:TPanel read FBody write SetBody stored IsWrongBody;
property Scroll:TScrollBar read FScroll write SetScroll stored
IsWrongScrool;
property Datasource: TDatasource read FDatasource write SetDatasource
default nil;
property OnKeyDown;
property OnMouseWheel;
property Canvas: TCanvas read FCanvas;
end;

procedure Register;

implementation

procedure DBListView.Next();
begin
if not FDataSource.DataSet.EOF
then begin
FDataSource.DataSet.Next;
if FDataSource.DataSet.EOF
then FDataSource.DataSet.Prior
else pos:=pos+1;
end;
end;

procedure DBListView.Prior();
begin
if FDataSource.DataSet.RecNo-1>0
then begin
FDataSource.DataSet.Prior;
if FDataSource.DataSet.RecNo-1<0
then FDataSource.DataSet.next
else pos:=pos-1;
end;
end;

procedure DBListView.VCLKeyDown(var Key: Word; Shift: TShiftState);
begin
case key of
VK_UP, VK_NEXT: begin
if (((pos*fgora.Height)-fscroll.Position)<0)
then fscroll.Position:=fscroll.Position-((fscroll.Position mod
fgora.Height)+fgora.Height+1)
else begin
if ((pos-1)*fgora.Height)-fscroll.Position<=0
then begin
self.Prior();
fscroll.Position:=fscroll.Position-fgora.Height;
end
else self.prior;
end;
end;
VK_DOWN, VK_PRIOR: begin
if
(((((pos+1)*fgora.Height)+fgora.Height)-fscroll.Position)>self.Height)
then begin
fscroll.Position:=fscroll.Position+fgora.Height;
self.Next();
end
else self.Next;
end;
else exit;
end;
paint();
key:=0;
end;

procedure DBListView.CNKeyDown(var Message: TWMKeyDown);
var
ShiftState: TShiftState;
begin
with Message
do begin
ShiftState:=KeyDataToShiftState(KeyData);
VCLKeyDown(CharCode, ShiftState);
if CharCode=0
then Result:=1
else inherited
end;
end;

procedure DBListView.PaintWindow(DC: HDC);
begin
FCanvas.Lock;
try
FCanvas.Handle := DC;
try
Paint;
finally
FCanvas.Handle := 0;
end;
finally
FCanvas.Unlock;
end;
end;

procedure DBListView.Paint;
var
y, x, xx, yy, a, i: integer;
rect:TRect;
label xxxx;
begin
if not assigned(FGora)
then exit
else fgora.DoubleBuffered:=true;
if not assigned(FScroll)
then exit;

rect:=ClientRect;
FCanvas.Brush.Color:=clWindow;
FCanvas.Brush.Style:=bsSolid;
FCanvas.FillRect(rect);
if assigned(FDataSource) and (not FDataSource.DataSet.IsEmpty)
then begin
pos := fdatasource.DataSet.RecNo-1;
FGora.Visible := true;
FScroll.visible := true;
FScroll.OnChange:=@ChangeBar;
self.FScroll.Max:=(FDataSource.DataSet.RecordCount*fgora.Height)-
self.Height;
xx:=0;
for i:=1 to (((pos)*gora.Height-(self.FScroll.Position))div
fgora.Height)+2 do
begin
if FDataSource.DataSet.RecNo-1>0
then begin
FDataSource.DataSet.Prior;
if FDataSource.DataSet.RecNo-1<0
then FDataSource.DataSet.next
else xx:=xx+1;
end;
end;
yy:=0;
a := (((pos)*gora.Height-(self.FScroll.Position-self.Height))div
fgora.Height)+1;
for i:=-xx to a do
begin
FGora.Color:=fnoselectedcolor;
TPanel(FGora).Canvas.Clear;
TPanel(FGora).Paint;
for y:=0 to FGora.ControlCount-1 do
begin
TDBTExt(FGora.Controls[y]).canvas.clear;
TDBTExt(FGora.Controls[y]).Paint;
end;

if i<>0
then rysuj(fgora.Width, fgora.Height, FGora.Canvas,
((pos+i)*gora.Height)-(self.FScroll.Position));
if i<a
then begin
FDataSource.DataSet.Next;
if i>0
then yy:=yy+1;
if FDataSource.DataSet.EOF
then begin
yy:=yy-1;
goto xxxx;
end;
end;
end;
xxxx:
for x:=1 to yy+1 do
FDataSource.DataSet.Prior;
FScroll.Left:=self.Width-FScroll.Width;
FScroll.top := 0;
FGora.Color:=fselectedcolor;
FGora.Top:=(pos)*gora.Height-(self.FScroll.Position);
end
else begin
if csDesigning in ComponentState
then FGora.Color:=fnoselectedcolor
else begin
fgora.Visible := false;
FScroll.visible := false;
end;
end;
end;

procedure DBListView.Rysuj(w, h: integer; c: TCanvas; y: integer);
var
tmp: graphics.TBitmap;
r: trect;
begin
r:=classes.Rect(0, 0, w, h);
tmp:=graphics.TBitmap.Create;
tmp.Width:=w;
tmp.Height:=h;
tmp.Canvas.CopyRect(r, c, r);
FCanvas.draw(0, y, tmp);
tmp.Free;
tmp:=nil;
end;

procedure DBListView.SetParent(AParent: TWinControl);
begin
inherited;
CreateGora;
CreateScroll;
end;

procedure DBListView.PaletteCreated;
begin
inherited;
CreateGora;
CreateScroll;
end;

destructor DBListView.Destroy();
begin
FCanvas.Free;
if assigned(FGora)
then FGora.Free;
if assigned(FScroll)
then FScroll.Free;
if assigned(FBody)
then FBody.Free;
inherited;
end;

function DBListView.IsWrongGora: Boolean;
begin
result:=(ControlCount>1) and (Controls[1]<>FGora);
end;

function DBListView.IsWrongBody: Boolean;
begin
result:=(ControlCount>1) and (Controls[1]<>FBody);
end;

function DBListView.IsWrongScrool: Boolean;
begin
result:=(ControlCount>1) and (Controls[1]<>FScroll);
end;

function DBListView.Count(): integer;
begin
if assigned(FDatasource)
then Result:=FDatasource.DataSet.FieldCount
else Result:=0;
end;

procedure DBListView.ChangeBar(Sender: TObject);
begin
if not assigned(fgora) or not assigned(fscroll) or not
assigned(FDataSource)
then exit;
if ((self.FScroll.Position div fgora.Height)+1)>pos
then self.Next()
else if(((pos*fgora.Height)+fgora.Height)-
self.FScroll.Position)>(self.Height-1)
then self.Prior();
Paint;
end;

procedure DBListView.SetDataSource(const Value: TDataSource);
begin
if FDataSource<>value
then FDataSource := value;
end;

procedure DBListView.SetGora(const Value: TPanel);
begin
if FGora=Value
then exit;
if assigned(FGora) and (FGora=defGora)
then defGora.Parent:=nil;
if assigned(Value) and (Value.Parent<>self)
then Value.Parent:=self;
if (FBody=Value) and assigned(FBody)
then Body:=nil;
FGora:=Value;
NaprawGora;
end;

procedure DBListView.SetScroll(const Value: TScrollBar);
begin
if FScroll=Value
then exit;
if assigned(FScroll) and (FScroll=defScrool)
then defScrool.Parent:=nil;
if assigned(Value) and (Value.Parent<>self)
then Value.Parent:=self;
if (FScroll=Value) and assigned(FScroll)
then Scroll:=nil;
FScroll:=Value;
NaprawScroll;
end;

procedure DBListView.SetBody(const Value: TPanel);
begin
if FBody=Value
then exit;
if assigned(Value) and (Value.Parent<>self)
then Value.Parent:=self;
if (FGora=Value) and assigned(FGora)
then FGora:=nil;
FBody:=Value;
Naprawbody;
end;

procedure DBListView.NaprawScroll;
begin
if assigned(fscroll)
then begin
fscroll.Align:=alright;
fscroll.Kind:=sbvertical;
end;
end;

procedure DBListView.NaprawBody;
var
i: integer;
begin
if assigned(fbody)
then begin
if assigned(fscroll) and (fscroll.Visible)
then i:=fscroll.Width
else i:=0;
fbody.Caption:='';
fbody.Width:=self.Width-i;
fbody.Left:=0;
end;
end;

procedure DBListView.NaprawGora();
var
i: integer;
begin
if assigned(fgora)
then begin
if assigned(fscroll) and (fscroll.Visible)
then i:=fscroll.Width
else i:=0;
fgora.Caption:='';
fgora.Width:=self.Width-i;
fgora.Left:=0;
end;
end;

procedure DBListView.CreateGora;
var
own:TComponent;
n:integer;
begin
if assigned(FGora) or assigned(defGora) or not (csDesigning in
ComponentState) or (csLoading in ComponentState)
or (csDestroying in ComponentState)
then exit;
if assigned(Owner)
then own:=Owner
else own:=self;
FGora:=TPanel.Create(own);
defGora:=FGora;
n:=0;
repeat
inc(n);
try
FGora.Name:='Gora'+inttostr(n);
n:=-1;
except
end;
until n=-1;
FGora.Parent:=self;
NaprawGora();
end;

procedure DBListView.CreateScroll;
var
own:TComponent;
n:integer;
begin
if assigned(FScroll) or assigned(defScrool) or not (csDesigning in
ComponentState) or (csLoading in ComponentState)
or (csDestroying in ComponentState)
then exit;
if assigned(Owner)
then own:=Owner
else own:=self;
FScroll:=TScrollBar.Create(own);
defScrool:=FScroll;
n:=0;
repeat
inc(n);
try
FScroll.Name:='Scroll'+inttostr(n);
n:=-1;
except
end;
until n=-1;
FScroll.Parent:=self;
end;

procedure DBListView.Loaded;
var
i:integer;
begin
inherited;
for i:=0 to ControlCount-1
do begin
if Controls is TPanel
then begin
if (Controls<>FGora) and (Controls<>FBody)
then begin
if not assigned(FGora)
then Gora:=Controls as TPanel
else if not assigned(FBody)
then Body:=Controls as TPanel;
end;
end
else if Controls is TScrollBar
then begin
if (Controls<>FScroll)
then begin
if not assigned(FScroll)
then Scroll:=Controls as TScrollBar;
end;
end
end;
if not assigned(FGora)
then CreateGora;
if not assigned(FScroll)
then CreateScroll;
end;

constructor DBListView.Create(TheOwner: TComponent);
begin
inherited;
FSelectedColor := clblue;
FNoSelectedColor := clwhite;
rys:=false;
pos:=0;
prevpos:=0;
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
DoubleBuffered:=true;
end;

procedure Register;
begin
RegisterComponents('MAD',[DBListView]);
end;

end.