www.pudn.com > sybase_dblib4.zip > sybchecklistbox.pas

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.