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

{$H+} 
unit sybtable; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Grids,DsgnIntf,sybase_components,sybquery,sybnavigator; 
 
type 
  SybObjectname = string[30]; 
  sqlstring = array[0..8000] of char; 
type 
  Tsybobjectproperty = class(TStringProperty) 
  public 
    procedure GetValues(TheProc: TGetStrProc); override; 
    function getattributes:Tpropertyattributes; override; 
  end; 
 
type 
  Tstringsproperty = class(TPropertyEditor) 
  public 
    function getvalue:string; override; 
    procedure setvalue(const value :string); override; 
    procedure edit;override; 
    function getattributes:Tpropertyattributes; override; 
  end; 
 
type 
{  tsybtable = class(TWinControl)} 
  TSybTable = class(TComponent) 
  private 
    { Private declarations } 
    FSql            :ansistring; 
    FTablename      :SybObjectname; 
    FDbname         :SybObjectname; 
    FDesignActive   :boolean; 
    FMaxCount       :integer; 
    FColumnCount    :integer; 
    FBuffersize     :integer; 
    FRowsReturned   :boolean; 
    FAutoDbProc     :boolean; 
    FUpdateFields   :boolean; 
    FDbProc         :integer; 
    FSprocUpdate    :SybObjectname; 
    FSprocInsert    :SybObjectname; 
    FSprocDelete    :SybObjectname; 
{    FFields_List    :TStrings;} 
    procedure SetUpdateSProc(Value :SybObjectname); 
    procedure SetInsertSProc(Value :SybObjectname); 
    procedure SetDeleteSProc(Value :SybObjectname); 
    procedure SetAutoDbProc(Value :boolean); 
    procedure setupdatefields(Value:boolean); 
    procedure SetDbProc(Value :integer); 
    procedure SetDbName(Value :SybObjectname); 
    procedure SetDesignActive(Value :boolean); 
    procedure SetMaxCount(Value :integer); 
    procedure SetBuffersize(Value :integer); 
    procedure SetRowsReturned(Value :boolean); 
    procedure Settablename(Value :SybObjectname); 
    procedure Readfieldscount(Reader: TReader); 
    procedure Writefieldscount(Writer: TWriter); 
    procedure Writefields(Writer: TWriter); 
    procedure Readfields(Reader: TReader); 
    procedure update_fields; 
{    procedure SetFields_List(Value:TStrings);} 
  protected 
    { Protected declarations } 
    first_flag :boolean; 
    procedure get_dbproc; 
    procedure get_databasefields; 
    procedure DefineProperties(Filer: TFiler); override; 
    procedure setname(const NewName:Tcomponentname); override; 
    procedure LoadSqlFromFile(FileName :string); 
  public 
    fieldscount     :smallint; 
    fields          :array[1..255] of SybObjectname; 
    datafields      :array[1..255] of SybObjectname; 
    datafieldscount :smallint; 
    SqlCommand      :sqlstring; 
    Login,Retcode,retcode2,nocols,col:integer; 
    dbprocc:integer; 
    numcols         :integer; 
    firstrownum,lastrownum,currrownum:longint; 
    navigator       :tsybnavigator; 
{    fldslist    :tstrings;} 
    constructor create(AOwner:TComponent); override; 
    destructor destroy; 
    function sqlexec:integer; 
    function nextrow:integer; 
    function prevrow:integer; 
    function firstrow:integer; 
    function lastrow:integer; 
    function row_exists:boolean; 
    function column(index:byte):string; 
    function heading(index:byte):string; 
    function coltype(index:byte):string; 
    function collength(index:byte):integer; 
    function ischar(index:byte):boolean; 
    procedure addfield(value:SybObjectname); 
    procedure deletefield(value:SybObjectname); 
 
    procedure loaded; override; 
    function insert_record:integer; 
    function update_record:integer; 
    function delete_record:integer; 
  published 
    { Published declarations } 
    property RowsReturned:boolean read fRowsReturned write setRowsReturned default false; 
    property DbName :SybObjectname read FDbName write setDbname; 
    property TableName :SybObjectname read FTableName write settablename; 
    property DesignActive:boolean read fdesignactive write setdesignactive stored false; 
    property MaxCount :integer read FMaxCount write SetMaxCount default 0; 
    property ColumnCount :integer read FColumnCount; 
    property BufferSize :integer read FBuffersize write SetBuffersize; 
    property AutoDbProc:boolean read FAutoDbProc write SetAutoDbProc default true; 
    property DbProc:integer read FDbproc write SetDbProc default 0; 
    property SProcUpdate :SybObjectname read FSProcUpdate write setUpdateSProc; 
    property SProcInsert :SybObjectname read FSProcInsert write setInsertSProc; 
    property SProcDelete :SybObjectname read FSProcDelete write setDeleteSProc; 
    property UpdateFields:boolean read fupdatefields write setupdatefields default true; 
{    property FieldsLst:TStrings read FFields_List write SetFields_List;} 
  end; 
 
procedure Register; 
 
implementation 
uses sybase32, 
     objectlistdlg, 
     ansistringedit, 
     sybdatabase, 
     sybsproc, 
     sybcombobox, 
     sybcheckbox, 
     sybradiobutton, 
     sybmemo; 
 
procedure Register; 
begin 
  RegisterPropertyEditor(TypeInfo(SybObjectname),tsybtable,'',Tsybobjectproperty); 
  RegisterPropertyEditor(TypeInfo(AnsiString),tsybtable,'Sql',TstringsProperty); 
  RegisterComponents('Sybase DBLIB', [tsybtable]); 
end; 
 
procedure tsybtable.DefineProperties(Filer: TFiler); 
begin 
  inherited DefineProperties(Filer); 
  Filer.DefineProperty('FieldsProp', Readfields, Writefields,fieldscount>0); 
  Filer.DefineProperty('FieldsCountProp',Readfieldscount,Writefieldscount,true); 
end; 
 
procedure tsybtable.LoadSqlFromFile(FileName :string); 
begin 
  fsql:=sybase_components.LoadFromFile(FileName); 
end; 
 
procedure tsybtable.SetUpdateSProc(Value :SybObjectname); 
begin 
  FSProcUpdate:=value; 
end; 
 
procedure tsybtable.SetInsertSProc(Value :SybObjectname); 
begin 
  FSProcInsert:=value; 
end; 
 
procedure tsybtable.SetDeleteSProc(Value :SybObjectname); 
begin 
  FSProcDelete:=value; 
end; 
 
procedure TSybtable.Readfields(Reader: TReader); 
var i:integer; 
begin 
  Reader.ReadListBegin; 
  fieldscount:=0; 
  while not Reader.EndOfList do   begin     inc(fieldscount);     fields[fieldscount]:=Reader.ReadString;   end;   Reader.ReadListEnd; 
end; 
 
procedure TSybtable.Writefields(Writer: TWriter); 
var   I: Integer; 
begin 
  Writer.WriteListBegin; 
  for I := 1 to fieldscount do     Writer.WriteString(fields[I]); 
  Writer.WriteListEnd; 
end; 
 
procedure tsybtable.Readfieldscount(Reader: TReader); 
begin 
  fieldscount := Reader.ReadInteger; 
end; 
 
procedure tsybtable.Writefieldscount(Writer: TWriter); 
begin 
  Writer.WriteInteger(fieldscount); 
end; 
 
procedure TSybtable.loaded; 
begin 
  inherited loaded; 
{  setfields_list(fldslist);} 
end; 
 
{procedure TSybtable.Setfields_List(Value :TStrings); 
begin 
  Ffields_List.assign(Value); 
end;} 
 
constructor tsybtable.create(AOwner:TComponent); 
begin 
  inherited create(AOwner); 
  first_flag:=true; 
  Fdesignactive:=false; 
  Fautodbproc:=true; 
  FBuffersize:=0; 
  fupdatefields:=true; 
  Fdbproc:=0; 
{  ffields_list:=tstringlist.create; 
  fldslist:=tstringlist.create; 
  setfields_list(fldslist);} 
 
  if tablelist = nil then 
  begin 
    tablelist:=TList.create; 
  end; 
end; 
 
destructor tsybtable.destroy; 
begin 
  tablelist.remove(self); 
  inherited destroy; 
end; 
 
procedure TSybtable.setname(const NewName:Tcomponentname); 
begin 
  inherited setname(NewName); 
  if tablelist.indexof(self) = -1 then 
    tablelist.add(self) 
  else 
  begin 
    tablelist.items[tablelist.indexof(self)]:=self; 
  end; 
end; 
 
procedure tsybtable.SetDbProc(Value :integer); 
begin 
  FDbproc:=Value; 
  Dbprocc:=Value; 
end; 
 
procedure Tsybtable.SetAutoDbPRoc(Value :boolean); 
begin 
  FAutoDbProc:=value; 
end; 
 
procedure Tsybtable.SetUpdatefields(Value :boolean); 
begin 
  Fupdatefields:=value; 
end; 
 
procedure tsybtable.SetRowsReturned(Value:boolean); 
begin 
  FRowsReturned:=value; 
end; 
 
procedure tsybtable.Setdesignactive(Value :boolean); 
begin 
  Fdesignactive:=Value; 
  get_dbproc; 
  if length(tablename) > 0 then 
    get_databasefields; 
{  setfields_list(fldslist);} 
end; 
 
procedure Tsybtable.SetMaxCount(Value :integer); 
begin 
  FMaxCount:=Value; 
end; 
 
procedure Tsybtable.SetBuffersize(Value :integer); 
var p :pchar; 
    s :string[20]; 
begin 
  FBuffersize:=Value; 
  s:=inttostr(value); 
  new(p); 
  strpcopy(p,s); 
  if (Value > 0) then 
  begin 
    retcode:=dbsetopt(dbproc,DBBUFFER,p,-1); 
    dispose(p); 
  end; 
end; 
 
procedure tsybtable.SetDbname(Value :SybObjectname); 
begin 
  FDbname:=value; 
  get_dbproc; 
end; 
 
function tsybtable.sqlexec:integer; 
var value             :string[255]; 
    linenum,i,j,rows  :integer; 
    p                 :pchar; 
begin 
  if navigatorlist <> nil then 
  begin 
    for i:=0 to navigatorlist.count-1 do 
    begin 
      if tsybnavigator(navigatorlist[i]).DataSet = name then 
      begin 
        navigator:=tsybnavigator(navigatorlist[i]); 
        break; 
      end; 
    end;   
  end 
  else 
  begin 
    navigator:=tsybnavigator.create(nil); 
  end; 
 
  get_dbproc; 
  if dbprocc = 0 then 
    exit; 
 
  Fsql:='select * from ' + FTableName; 
 
  if (retcode2 <> More_Rows) then 
  begin 
    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 
    begin 
      setrowsreturned(true); 
    end; 
 
    numcols:=dbnumcols(dbProc); 
    FColumncount:=numcols; 
    Result:=retcode; 
    retcode2:=0; 
    if retcode = Succeed then 
    begin 
      firstrownum:=1; 
      lastrownum:=1; 
{      retcode2 := dbnextrow(dbProc);} 
    end; 
  end; 
end; 
 
procedure Tsybtable.Settablename(Value :SybObjectname); 
begin 
  Ftablename:=value; 
  get_databasefields; 
end; 
 
function Tsybtable.row_exists:boolean; 
var res:integer; 
begin 
  result:=false; 
  res:=nextrow; 
  if res = -1 then 
    result:=true; 
end; 
 
function Tsybtable.nextrow:integer; 
begin 
  result:=0; 
  if (retcode = Succeed) then 
  begin 
    retcode2 := dbnextrow(dbProc); 
    Result:=retcode2; 
    if (fupdatefields) and (retcode2=-1) then 
      update_fields; 
    case retcode2 of 
      -1 :begin 
            if first_flag then 
            begin 
              navigator.btnfirst.enabled:=false; 
              navigator.btnprior.enabled:=false; 
              navigator.btnnext.enabled:=true; 
              navigator.btnlast.enabled:=true; 
              first_flag:=false; 
            end 
            else 
            begin 
              navigator.btnfirst.enabled:=true; 
              navigator.btnprior.enabled:=true; 
              navigator.btnnext.enabled:=true; 
              navigator.btnlast.enabled:=true; 
            end; 
          end; 
      -2 :begin 
            if first_flag then 
            begin 
              navigator.btnfirst.enabled:=false; 
              navigator.btnprior.enabled:=false; 
              navigator.btnnext.enabled:=false; 
              navigator.btnlast.enabled:=false; 
            end; 
          end; 
    end; 
    currrownum:=dbcurrow(dbProc); 
    if currrownum > lastrownum then 
      lastrownum:=currrownum; 
  end 
  else 
    result:=No_More_Rows; 
end; 
 
function Tsybtable.prevrow:integer; 
var value :string[255]; 
    retcode3:integer; 
begin 
  result:=0; 
  if (retcode = Succeed) then 
  begin 
    currrownum:=dbcurrow(dbProc); 
    if currrownum > 1 then 
      dec(currrownum); 
    retcode3 := dbgetrow(dbproc,currrownum); 
    if fupdatefields then 
      update_fields; 
    if currrownum = 1 then 
    begin 
      navigator.btnfirst.enabled:=false; 
      navigator.btnprior.enabled:=false; 
      navigator.btnnext.enabled:=true; 
      navigator.btnlast.enabled:=true; 
    end 
    else 
    begin 
      navigator.btnfirst.enabled:=true; 
      navigator.btnprior.enabled:=true; 
      navigator.btnnext.enabled:=true; 
      navigator.btnlast.enabled:=true; 
    end; 
    Result:=retcode3; 
  end 
  else 
  begin 
    retcode:=No_More_Rows; 
    result:=No_More_Rows; 
  end; 
end; 
 
 
function Tsybtable.firstrow:integer; 
var value :string[255]; 
    retcode3:integer; 
begin 
 
  result:=0; 
  if (retcode = Succeed) then 
  begin 
    retcode3 := dbgetrow(dbproc,firstrownum); 
    Result:=retcode3; 
    if fupdatefields then 
      update_fields; 
    navigator.btnfirst.enabled:=false; 
    navigator.btnprior.enabled:=false; 
    navigator.btnnext.enabled:=true; 
    navigator.btnlast.enabled:=true; 
  end 
  else 
    result:=No_More_Rows; 
end; 
 
function Tsybtable.lastrow:integer; 
var value :string[255]; 
    retcode3:integer; 
begin 
  result:=0; 
  if (retcode = Succeed) then 
  begin 
    retcode3 := dbgetrow(dbproc,dblastrow(dbProc)); 
    Result:=retcode3; 
    if fupdatefields then 
      update_fields; 
    navigator.btnfirst.enabled:=true; 
    navigator.btnprior.enabled:=true; 
    navigator.btnnext.enabled:=false; 
    navigator.btnlast.enabled:=false; 
  end 
  else 
    result:=No_More_Rows; 
end; 
 
function Tsybtable.column(index:byte):string; 
begin 
  result:=strpas(dbvalue(dbproc,index)) 
end; 
 
function Tsybtable.heading(index:byte):string; 
begin 
  result:=strpas(dbcolname(dbproc,index)) 
end; 
 
function Tsybtable.coltype(index:byte):string; 
begin 
  result:=strpas(dbprtype(dbcoltype(dbproc,index))) 
end; 
 
function Tsybtable.collength(index:byte):integer; 
begin 
  result:=dbcollen(dbproc,index) 
end; 
 
function Tsybtable.ischar(index:byte):boolean; 
var colltyp  :string; 
begin 
  result:=false; 
  if (coltype(index)='char') 
    or (coltype(index)='text') 
    or (coltype(index)='datetime') 
    or (coltype(index)='smalldatetime') then 
  begin 
    result:=true; 
    exit; 
  end; 
  if (coltype(index)='binary') 
    or (coltype(index)='tinyint') 
    or (coltype(index)='smallint') 
    or (coltype(index)='int') 
    or (coltype(index)='float') 
    or (coltype(index)='real') 
    or (coltype(index)='numeric') 
    or (coltype(index)='decimal') 
    or (coltype(index)='bit') 
    or (coltype(index)='money') 
    or (coltype(index)='smallmoney') 
    or (coltype(index)='sum') 
    or (coltype(index)='avg') 
    or (coltype(index)='count') 
    or (coltype(index)='min') 
    or (coltype(index)='max') then 
  begin 
    result:=false; 
  end; 
end; 
 
procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc); 
var 
  Login,Retcode,retcode2,i:integer; 
  dbname :SybObjectname; 
  s      :string; 
  tslist:Tsybtable; 
  SqlCommand :sqlstring; 
  adatabase :tsybdatabase; 
  asproc    :tsybsproc; 
begin 
  tslist:=Tsybtable(getcomponent(0)); 
 
{  if getname='FieldsLst' then 
  begin 
    for i:=0 to tslist.ffields_list.count-1 do 
      theproc(tslist.ffields_list[i]); 
  end;} 
 
  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 (getname = 'SProcUpdate') 
    or (getname = 'SProcInsert') 
    or (getname = 'SProcDelete') then 
  begin 
    if sybase_components.sproclist <> nil then 
      for i:=0 to (sybase_components.sproclist.count-1) do 
      begin 
        asproc:=sproclist[i]; 
        theproc(asproc.name); 
      end; 
  end 
  else 
  if tslist.dbproc > 40 then 
  begin 
    if getname = 'TableName' then 
    begin 
      strpcopy(Sqlcommand,'select name from sysobjects where type in ("U","S") order by name'); 
 
      Retcode := dbcmd(tslist.dbProc,@Sqlcommand); 
      Retcode := Dbsqlexec(tslist.dbProc); 
      Retcode := dbresults(tslist.dbProc); 
      retcode2:=0; 
      while (retcode <> No_more_results) and (retcode <> Fail) do 
      begin 
        if retcode = Succeed then 
        begin 
          retcode2 := dbnextrow(tslist.dbProc); 
          while retcode2 <> No_More_Rows do 
          Begin 
            theproc(strpas(dbvalue(tslist.dbproc,1))); 
            retcode2 := dbnextrow(tslist.dbProc); 
          end; 
        end; 
        Retcode := dbresults(tslist.dbproc); 
      end; 
    end; 
{    ServList.add(copy(l,2,length(l)-2));} 
 
 
  end 
  else 
  showmessage('Not connected to database !'); 
end; 
 
function Tsybobjectproperty.getattributes:Tpropertyattributes; 
begin 
  Result := [paValueList,paAutoUpdate,paMultiSelect]; 
end; 
 
procedure tsybtable.get_dbproc; 
var i         :integer; 
    adatabase :tsybdatabase; 
begin 
  if not autodbproc then 
    exit; 
  if databaseslist <> nil then 
    for i:=0 to (sybase_components.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 
  OKBottomDlg:=TOKBottomDlg.create(nil); 
  OKBottomDlg.memo.text:=getstrvalue; 
  OKBottomDlg.showmodal; 
  if OKBottomDlg.modalresult = mrok then 
  begin 
    setstrvalue(OKBottomDlg.memo.text); 
  end; 
end; 
 
function Tstringsproperty.getattributes:Tpropertyattributes; 
begin 
  result:=[padialog]; 
end; 
 
procedure tsybtable.addfield(value:SybObjectname); 
var i  :smallint; 
begin 
  for i:=1 to fieldscount do 
  begin 
    if fields[i]=value then 
      exit; 
  end; 
  inc(fieldscount); 
  fields[fieldscount]:=value; 
end; 
 
procedure tsybtable.deletefield(value:SybObjectname); 
var i,j  :smallint; 
    newfields:array[1..100] of SybObjectname; 
begin 
  j:=0; 
  for i:=1 to fieldscount do 
  begin 
    if fields[i] <> value then 
    begin 
      inc(j); 
      newfields[j]:=fields[i]; 
    end; 
  end; 
  fieldscount:=j; 
  for i:=1 to fieldscount do 
    fields[i]:=newfields[i]; 
end; 
 
procedure tsybtable.get_databasefields; 
var tmpquery :tsybquery; 
begin 
  if FDesignActive then 
  begin 
    get_dbproc; 
    tmpquery:=tsybquery.create(nil); 
    tmpquery.dbname:=dbname; 
    tmpquery.dbproc:=dbproc; 
    tmpquery.sql:='select name from syscolumns where id = object_id("' + tablename + '") order by colid'; 
    datafieldscount:=0; 
    tmpquery.sqlexec; 
    if (tmpquery.nextrow=-1) or (tmpquery.nextrow=1) then 
    begin 
      inc(datafieldscount); 
      datafields[datafieldscount]:=tmpquery.column(1); 
{      fldslist.add(datafields[datafieldscount]);} 
      while tmpquery.nextrow = -1 do 
      begin 
        inc(datafieldscount); 
        datafields[datafieldscount]:=tmpquery.column(1); 
{        fldslist.add(datafields[datafieldscount]);} 
      end; 
    end; 
    tmpquery.free; 
  end; 
 
end; 
 
function TSybTable.insert_record:integer; 
var i       :integer; 
begin 
  showmessage(inttostr(sybase_components.fieldslist.count)); 
  for i:=1 to fieldscount do 
  begin 
    showmessage(fields[i] + ' = ' + tsybfield(fieldslist.items[i-1]).value); 
  end; 
end; 
 
function TSybTable.update_record:integer; 
begin 
  {} 
end; 
 
function TSybTable.delete_record:integer; 
begin 
  {} 
end; 
 
procedure TSybTable.update_fields; 
var i,j    :integer; 
    field  :tsybfield; 
begin 
  for i:=1 to numcols do 
  begin 
 
    if fieldslist <> nil then 
    begin 
      for j:=0 to fieldslist.count-1 do 
      begin 
        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybedit') then 
        begin 
          if (tsybfield(fieldslist[j]).dataset = name) 
           and (tsybfield(fieldslist[j]).datafield = heading(i)) then 
          tsybfield(fieldslist[j]).value:=column(i); 
        end 
        else 
        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybmemo') then 
        begin 
          if (tsybmemo(fieldslist[j]).dataset = name) 
           and (tsybmemo(fieldslist[j]).datafield = heading(i)) then 
           tsybmemo(fieldslist[j]).value:=column(i); 
        end 
        else 
        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybcheckbox') then 
        begin 
          if (tsybcheckbox(fieldslist[j]).dataset = name) 
           and (tsybcheckbox(fieldslist[j]).datafield = heading(i)) then 
          tsybcheckbox(fieldslist[j]).value:=column(i); 
        end 
        else 
        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybradiobutton') then 
        begin 
          if (tsybradiobutton(fieldslist[j]).tablename = name) 
           and (tsybradiobutton(fieldslist[j]).datafield = heading(i)) then 
          tsybradiobutton(fieldslist[j]).value:=column(i); 
        end; 
      end; 
    end; 
 
  end; 
end; 
 
end.