DBList
lazarus / 16-Databases

----------------------------------------------------------------------
mad · 2008-06-26 06:59

Free for all.. non-commercial and commercial use.
This component work incorrectly. I don't know how repair DBList.
Please help.





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.Heig
ht)-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.