sybchecklistbox.pas

sybase大全

unit sybchecklistbox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,DsgnIntf,checklst;

type
  SybObjectname = string[30];

type
  Tsybobjectproperty = class(TStringProperty)
  public
    procedure GetValues(TheProc: TGetStrProc); override;
    function getattributes:Tpropertyattributes; override;
  end;

type
  Tstringsproperty = class(TStringProperty)
  public
    function getattributes:Tpropertyattributes; override;
    function getvalue:string; override;
    procedure edit;override;
    procedure setvalue(const value :string); override;
  end;

type
 TSybCheckListBox = class(TCheckListBox)
  private
    { Private declarations }
    FCheckValue  :string;
    FSql         :ansistring;
    FTablename   :SybObjectname;
    Ffieldname   :SybObjectname;
    FDbname      :SybObjectname;
    FDesignActive:boolean;
    FRowsReturned:boolean;
    FAutoDbProc  :boolean;
    FAutoSize    :boolean;
    FDbProc      :integer;
    fcomp_type   :string;
    procedure SetCheckValue(value :string);
    procedure SetDbProc(Value :integer);
    procedure SetAutoDbProc(Value :boolean);
    procedure SetAutoSize(Value :boolean);
    procedure SetSql(Value :ansistring);
    procedure Settablename(Value :SybObjectname);
    procedure Setfieldname(Value :SybObjectname);
    procedure SetDbName(Value :SybObjectname);
    procedure SetDesignActive(Value :boolean);
    procedure SetRowsReturned(Value :boolean);
    function getvalue:string;
  protected
    { Protected declarations }
    procedure get_dbproc;
  public
    { Public declarations }
    SqlCommand:array[0..4096] of char;
    dbprocc:integer;
    Login,Retcode,retcode2,nocols,col:integer;
    tablenm,fieldnm:SybObjectname;
    databases:array[1..10] of SybObjectname;
    databasedbprocs:array[1..10] of integer;
    property comp_type:string read fcomp_type;
    constructor create(AOwner:TComponent); override;
    destructor destroy; override;
    procedure addsql(Value :ansistring);
    procedure clearsql;
    function sqlexec:integer;
    procedure setname(const NewName:Tcomponentname); override;
    procedure setlistvalue(value:string);
  published
    { Published declarations }
    property CheckValue :string read FCheckValue write SetCheckValue;
    property DbName :SybObjectname read FDbName write setDbname;
    property Sql :string read FSql write SetSql;
    property TableName :SybObjectname read FTableName write settablename;
    property FieldName :SybObjectname read FFieldName write setfieldname;
    property DesignActive:boolean read fdesignactive write setdesignactive stored false;
    property AutoSize:boolean read FAutoSize write SetAutoSize default false;
    property AutoDbProc:boolean read FAutoDbProc write SetAutoDbProc default true;
    property RowsReturned:boolean read fRowsReturned write setRowsReturned default false;
    property DbProc:integer read FDbproc write SetDbProc default 0;
    property Value:string read getvalue;
  end;

procedure Register;

implementation
uses sybase32,
     ansistringedit,
     sybase_components,
     sybdatabase;

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(SybObjectname),TSybCheckListBox,'',Tsybobjectproperty);
  RegisterPropertyEditor(TypeInfo(String),TSybCheckListBox,'Sql',TstringsProperty);
  RegisterComponents('Sybase DBLIB', [TSybCheckListBox]);
end;

constructor TSybCheckListBox.create(AOwner:TComponent);
begin
  inherited create(AOwner);
  fcomp_type:='listbox';
  Fdesignactive:=false;
  Fautodbproc:=true;
  Fautosize:=false;
  Fdbproc:=0;
  if sybase_components.listboxList = nil then
    sybase_components.listboxlist:=TList.create;
end;

destructor TSybCheckListBox.destroy;
begin
  listboxlist.remove(self);
  inherited destroy;
end;

procedure TSybCheckListBox.setcheckvalue(value:string);
begin
  fcheckvalue:=value;
end;

procedure TSybCheckListBox.setlistvalue(value:string);
var i :integer;
begin
  for i:=0 to items.count-1 do
  begin
    if items[i]=value then
    begin
      itemindex:=i;
      exit;
    end;
  end;
end;

function TSybCheckListBox.getvalue:string;
begin
  result:=items[itemindex];
end;

procedure TSybCheckListBox.setname(const NewName:Tcomponentname);
var oldname :Tcomponentname;
begin
  oldname:=name;
  inherited setname(NewName);
  if listboxlist.indexof(self) = -1 then
    listboxlist.add(self)
  else
  begin
    listboxlist.items[listboxlist.indexof(self)]:=self;
  end;
end;

procedure TSybCheckListBox.SetDbProc(Value :integer);
begin
  FDbproc:=Value;
  Dbprocc:=Value;
end;

procedure TSybCheckListBox.SetSql(Value :ansistring);
begin
  FSql:=Value;
end;

procedure TSybCheckListBox.SetAutoDbPRoc(Value :boolean);
begin
  FAutoDbProc:=value;
end;

procedure TSybCheckListBox.SetAutoSize(Value :boolean);
begin
  FAutoSize:=value;
end;

procedure TSybCheckListBox.SetRowsReturned(Value:boolean);
begin
  FRowsReturned:=value;
end;

procedure TSybCheckListBox.Setdesignactive(Value :boolean);
begin

  if value then
  begin
    get_dbproc;
    if (length(sql) > 1)
      or ((length(ftablename)>0) and (length(ffieldname)>0)) then
      sqlexec;
  end;
  Fdesignactive:=Value;
end;

procedure TSybCheckListBox.addsql(Value :ansistring);
begin
  FSql:=FSql + Value;
end;

procedure TSybCheckListBox.clearsql;
begin
  FSql:='';
end;

function TSybCheckListBox.sqlexec:integer;
var value    :string[255];
    rows     :integer;
    p        :pchar;
    maxwdth  :integer;
    ln       :integer;
begin
  get_dbproc;
  if dbproc = 0 then
  begin
    result:=-99;
    exit;
  end;  
  maxwdth:=round(width/font.size);
  clear;
  if length(Fsql) = 0 then
    Fsql:='select ' + FFieldName + ' from ' + FTableName;
  Retcode := Dbcancel(dbProc);
  p:=pchar(Fsql);
  Retcode := dbcmd(dbProc,p);
  Retcode := Dbsqlexec(dbProc);
  Retcode := dbresults(dbProc);
  rows:=dbrows(dbProc);
  if rows = fail then
    setrowsreturned(false)
  else
    setrowsreturned(true);

  Result:=retcode;
  retcode2:=0;
  ln:=-1;
  while (retcode <> No_more_results) and (retcode <> Fail) do
  begin
    if retcode = Succeed then
    begin
      retcode2 := dbnextrow(dbProc);
      while retcode2 <> No_More_Rows do
      Begin
        if fautosize then
        begin
          if length(strpas(dbvalue(dbProcc,1))) > maxwdth then
            maxwdth:=length(strpas(dbvalue(dbProcc,1)));
        end;
        inc(ln);
        items.add(strpas(dbvalue(dbProc,1)));
        if trim(strpas(dbvalue(dbProc,2))) = checkvalue then
          checked[ln]:=true;
        retcode2 := dbnextrow(dbProc);
        result:=retcode2;
      end;
    end;
    Retcode := dbresults(dbproc);
  end;
  if fautosize then
  begin
    width:=maxwdth * font.size+10;
  end;
end;

procedure TSybCheckListBox.Settablename(Value :SybObjectname);
begin
  Ftablename:=value;
  tablenm:=value;
end;

procedure TSybCheckListBox.Setfieldname(Value :SybObjectname);
begin
  Ffieldname:=value;
  fieldnm:=value;
end;

procedure TSybCheckListBox.SetDbname(Value :SybObjectname);
var i:integer;
begin
  FDbname:=value;
  get_dbproc;
end;

procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc);
var
  SqlCommand:array[0..4096] of char;
  Login,Retcode,retcode2,i:integer;
  dbname :SybObjectname;
  s      :string;
  proc   :integer;
  tslist:TSybCheckListBox;
  adatabase :tsybdatabase;
begin
  tslist:=TSybCheckListBox(getcomponent(0));
  proc:=tslist.dbproc;
  if getname = 'DbName' then
  begin
    if databaseslist <> nil then
      for i:=0 to (sybase_components.databaseslist.count-1) do
      begin
        adatabase:=databaseslist[i];
        theproc(adatabase.name);
      end;
  end
  else
  if proc > 0 then
  begin
    if getname = 'TableName' then
      strpcopy(Sqlcommand,'select name from sysobjects where type in ("U","S") order by name')
    else
    begin
      s:='select sc.name from syscolumns sc,sysobjects so where sc.id=so.id and so.name="'+tslist.tablenm+'"';
      strpcopy(Sqlcommand,s);
    end;
    Retcode := dbcmd(proc,@Sqlcommand);
    Retcode := Dbsqlexec(proc);
    Retcode := dbresults(proc);
    retcode2:=0;
    while (retcode <> No_more_results) and (retcode <> Fail) do
    begin
      if retcode = Succeed then
      begin
        retcode2 := dbnextrow(proc);
        while retcode2 <> No_More_Rows do
        Begin
          theproc(strpas(dbvalue(proc,1)));
          retcode2 := dbnextrow(proc);
        end;
      end;
      Retcode := dbresults(proc);
    end;
  end;
end;

function Tsybobjectproperty.getattributes:Tpropertyattributes;
begin
  Result := [paValueList,paAutoUpdate,paMultiSelect];
end;

procedure TSybCheckListBox.get_dbproc;
var i          :integer;
    adatabase  :tsybdatabase;
begin
  if not autodbproc then
    exit;
  if databaseslist <> nil then
    for i:=0 to (databaseslist.count-1) do
   begin
       adatabase:=databaseslist[i];
      if FDbName = adatabase.name then
      begin
        setdbproc(adatabase.dbproc);
        break;
      end;
    end;
end;

function Tstringsproperty.getvalue:string;
begin
  result:=getstrvalue;
end;

procedure Tstringsproperty.setvalue(const value:string);
begin
  setstrvalue(value);
end;

procedure Tstringsproperty.edit;
var
  OKBottomDlg: TOKBottomDlg;
begin

  if getname = 'Sql' then
  begin
    OKBottomDlg:=TOKBottomDlg.create(nil);
    OKBottomDlg.memo.text:=getstrvalue;
    OKBottomDlg.showmodal;
    if OKBottomDlg.modalresult = mrok then
    begin
      setstrvalue(OKBottomDlg.memo.text);
    end;
  end;
end;

function Tstringsproperty.getattributes:Tpropertyattributes;
begin
  result:=[padialog];
end;


end.