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

{$H+} 
unit sybquery; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Grids,DsgnIntf,sybase_components,sybnavigator; 
 
type 
  SybObjectname = string[30]; 
 
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 
  TSybQuery = class(TComponent) 
  private 
    { Private declarations } 
    FSql            :ansistring; 
    FDesignSql      :ansistring; 
    FDbname         :SybObjectname; 
    FDesignActive   :boolean; 
    FMaxCount       :integer; 
    FColumnCount    :integer; 
    FBuffersize     :integer; 
    FRowsReturned   :boolean; 
    FAutoDbProc     :boolean; 
    FDbProc         :integer; 
    FUpdateFields   :boolean; 
    FCurrCmd        :integer; 
    procedure setupdatefields(Value:boolean); 
    procedure SetAutoDbProc(Value :boolean); 
    procedure SetDbProc(Value :integer); 
    procedure SetSql(Value :ansistring); 
    procedure SetDesignSql(Value :ansistring); 
    procedure SetDbName(Value :SybObjectname); 
    procedure SetMaxCount(Value :integer); 
    procedure SetBuffersize(Value :integer); 
    procedure SetRowsReturned(Value :boolean); 
    procedure Readfieldscount(Reader: TReader); 
    procedure Writefieldscount(Writer: TWriter); 
    procedure Writefields(Writer: TWriter); 
    procedure Readfields(Reader: TReader); 
    procedure update_fields; 
    procedure get_next_resultset; 
  protected 
    { Protected declarations } 
    procedure get_dbproc; 
    procedure SetDesignActive(Value :boolean); 
    procedure get_databasefields; 
    procedure DefineProperties(Filer: TFiler); override; 
    procedure setname(const NewName:Tcomponentname); override; 
  public 
    SqlCommand:array[0..8000] of char; 
    Login,Retcode,retcode2,nocols,col:integer; 
    dbprocc:integer; 
    numcols       :integer; 
    sproc_retcode :integer; 
    firstrownum,lastrownum,currrownum:longint; 
    first_flag :boolean; 
 
    fieldscount     :smallint; 
    fields          :array[1..255] of SybObjectname; 
    datafields      :array[1..255] of SybObjectname; 
    datafieldscount :smallint; 
    navigator       :tsybnavigator; 
    constructor create(AOwner:TComponent); override; 
    destructor destroy; override; 
    procedure loaded; override; 
    procedure addsql(Value :ansistring); 
    procedure clearsql; 
    function sqlexec:integer; virtual; 
    function nextrow:integer; virtual; 
    function prevrow:integer; virtual; 
    function firstrow:integer; virtual; 
    function lastrow:integer; virtual; 
    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 LoadSqlFromFile(FileName :string); 
    property RowsReturned:boolean read fRowsReturned write setRowsReturned default false; 
    property MaxCount :integer read FMaxCount write SetMaxCount default 0; 
    property CurrCmd :integer read FCurrCmd write FCurrCmd; 
  published 
    { Published declarations } 
    property ColumnCount :integer read FColumnCount; 
    property DbName :SybObjectname read FDbName write setDbname; 
    property Sql :ansistring read FSql write SetSql; 
    property DesignSql :ansistring read FDesignSql write SetDesignSql; 
    property DesignActive:boolean read fdesignactive write setdesignactive stored false; 
    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 UpdateFields:boolean read fupdatefields write setupdatefields default true; 
  end; 
 
procedure Register; 
 
implementation 
uses sybase32, 
     objectlistdlg, 
     ansistringedit, 
     sybmemo, 
     sybcheckbox, 
     sybradiobutton, 
     sybdatabase, 
     stdctrls; 
 
procedure Register; 
begin 
  RegisterPropertyEditor(TypeInfo(SybObjectname),tsybquery,'',Tsybobjectproperty); 
  RegisterPropertyEditor(TypeInfo(AnsiString),tsybquery,'Sql',TstringsProperty); 
  RegisterPropertyEditor(TypeInfo(AnsiString),tsybquery,'DesignSql',TstringsProperty); 
  RegisterComponents('Sybase DBLIB', [tsybquery]); 
end; 
 
procedure tsybquery.DefineProperties(Filer: TFiler); 
begin 
  inherited DefineProperties(Filer); 
  Filer.DefineProperty('FieldsProp', Readfields, Writefields,fieldscount>0); 
  Filer.DefineProperty('FieldsCountProp',Readfieldscount,Writefieldscount,true); 
end; 
 
procedure tsybquery.setname(const NewName:Tcomponentname); 
begin 
  inherited setname(NewName); 
  if querylist.indexof(self) = -1 then 
    querylist.add(self) 
  else 
  begin 
    querylist.items[querylist.indexof(self)]:=self; 
  end; 
end; 
 
destructor tsybquery.destroy; 
begin 
  querylist.remove(self); 
  inherited destroy; 
end; 
 
constructor tsybquery.create(AOwner:TComponent); 
begin 
  inherited create(AOwner); 
  fupdatefields:=true; 
  Fdesignactive:=false; 
  Fautodbproc:=true; 
  FBuffersize:=0; 
  Fdbproc:=0; 
  first_flag:=true; 
  if querylist = nil then 
  begin 
    querylist:=TList.create; 
  end; 
end; 
 
procedure tsybquery.SetUpdatefields(Value :boolean); 
begin 
  Fupdatefields:=value; 
end; 
 
procedure tsybquery.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 tsybquery.Writefields(Writer: TWriter); 
var   I: Integer; 
begin 
  Writer.WriteListBegin; 
  for I := 1 to fieldscount do     Writer.WriteString(fields[I]); 
  Writer.WriteListEnd; 
end; 
 
procedure tsybquery.Readfieldscount(Reader: TReader); 
begin 
  fieldscount := Reader.ReadInteger; 
end; 
 
procedure tsybquery.Writefieldscount(Writer: TWriter); 
begin 
  Writer.WriteInteger(fieldscount); 
end; 
 
procedure tsybquery.loaded; 
begin 
end; 
 
procedure tsybquery.SetDbProc(Value :integer); 
begin 
  FDbproc:=Value; 
  Dbprocc:=Value; 
end; 
 
procedure TSybquery.SetAutoDbPRoc(Value :boolean); 
begin 
  FAutoDbProc:=value; 
end; 
 
procedure tsybquery.SetSql(Value :ansistring); 
begin 
  FSql:=Value; 
end; 
 
procedure tsybquery.SetDesignSql(Value :ansistring); 
begin 
  FDesignSql:=Value; 
end; 
 
procedure tsybquery.SetRowsReturned(Value:boolean); 
begin 
  FRowsReturned:=value; 
end; 
 
procedure tsybquery.Setdesignactive(Value :boolean); 
begin 
  if value then 
  begin 
    get_dbproc; 
    get_databasefields; 
  end; 
  Fdesignactive:=Value; 
end; 
 
procedure TSybquery.SetMaxCount(Value :integer); 
begin 
  FMaxCount:=Value; 
end; 
 
procedure TSybquery.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); 
  end; 
  dispose(p); 
end; 
 
procedure tsybquery.addsql(Value :ansistring); 
begin 
  FSql:=FSql + Value; 
end; 
 
procedure tsybquery.clearsql; 
begin 
  FSql:=''; 
end; 
 
procedure tsybquery.SetDbname(Value :SybObjectname); 
begin 
  FDbname:=value; 
  get_dbproc; 
end; 
 
function tsybquery.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; 
  retcode:=dbcurcmd(dbProc); 
 
  if (retcode2 <> More_Rows) then 
  begin 
    Retcode := Dbcanquery(dbProc); 
    p:=pchar(Fsql); 
    Retcode:=dbcmd(dbProc,p); 
    Retcode:=dbsqlexec(dbProc); 
    FCurrCmd:=dbcurcmd(dbProc); 
    Retcode:=dbresults(dbProc); 
 
    rows:=dbrows(dbProc); 
    if rows = fail then 
      setrowsreturned(false) 
    else 
      setrowsreturned(true); 
    numcols:=dbnumcols(dbProc); 
    FColumncount:=numcols; 
    Result:=retcode; 
    retcode2:=0; 
    if retcode = Succeed then 
    begin 
      firstrownum:=1; 
      lastrownum:=1; 
{      retcode2 := dbnextrow(dbProc);} 
    end; 
  end; 
end; 
 
function Tsybquery.row_exists:boolean; 
var res:integer; 
begin 
  result:=false; 
  res:=nextrow; 
  if res = -1 then 
    result:=true; 
end; 
 
function Tsybquery.nextrow:integer; 
begin 
  result:=0; 
  sproc_retcode:=0; 
 
  if (retcode = Succeed) then 
  begin 
 
    retcode2 := dbnextrow(dbProc); 
    Result:=retcode2; 
 
    if retcode2 = No_More_Rows then 
    begin 
      if dbmorecmds(dbProc) = Succeed then 
        get_next_resultset; 
        retcode2 := dbnextrow(dbProc); 
        Result:=retcode2; 
    end; 
 
    if (fupdatefields) and (retcode2=-1) then 
      update_fields; 
    if (navigator <> nil) then 
    if trim(navigator.name) <> '' then 
    begin 
      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:=true; 
                navigator.btnprior.enabled:=true; 
                navigator.btnnext.enabled:=false; 
                navigator.btnlast.enabled:=false; 
              end; 
            end; 
      end; 
    end; 
    currrownum:=dbcurrow(dbProc); 
    if currrownum > lastrownum then 
      lastrownum:=currrownum; 
  end 
  else 
  begin 
    result:=No_More_Rows; 
  end; 
 
  sproc_retcode:=result; 
end; 
 
function Tsybquery.prevrow:integer; 
var value :string[255]; 
    retcode3:integer; 
begin 
  result:=0; 
  sproc_retcode:=0; 
  if (retcode = Succeed) then 
  begin 
    currrownum:=dbcurrow(dbProc); 
    if currrownum > 1 then 
      dec(currrownum); 
    retcode3 := dbgetrow(dbproc,currrownum); 
    if retcode3 = -2 then 
    begin 
      Result:=retcode3; 
      sproc_retcode:=result; 
      exit; 
    end; 
    if fupdatefields then 
      update_fields; 
    if navigator <> nil then 
    begin 
      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; 
    end; 
    Result:=retcode3; 
  end 
  else 
  begin 
    retcode:=No_More_Rows; 
    result:=No_More_Rows; 
  end; 
  sproc_retcode:=result; 
end; 
 
function Tsybquery.firstrow:integer; 
var value :string[255]; 
    retcode3:integer; 
begin 
  result:=0; 
  sproc_retcode:=0; 
  if (retcode = Succeed) then 
  begin 
    retcode3 := dbgetrow(dbproc,firstrownum); 
    Result:=retcode3; 
    if fupdatefields then 
      update_fields; 
    if navigator <> nil then 
    begin 
      navigator.btnfirst.enabled:=false; 
      navigator.btnprior.enabled:=false; 
      navigator.btnnext.enabled:=true; 
      navigator.btnlast.enabled:=true; 
    end; 
  end 
  else 
    result:=No_More_Rows; 
  sproc_retcode:=result; 
end; 
 
function Tsybquery.lastrow:integer; 
var value :string[255]; 
    retcode3:integer; 
begin 
  result:=0; 
  sproc_retcode:=0; 
  if (retcode = Succeed) then 
  begin 
    retcode3 := dbgetrow(dbproc,dblastrow(dbProc)); 
    if fupdatefields then 
      update_fields; 
    if navigator <> nil then 
    begin 
      navigator.btnfirst.enabled:=true; 
      navigator.btnprior.enabled:=true; 
      navigator.btnnext.enabled:=false; 
      navigator.btnlast.enabled:=false; 
      Result:=retcode3; 
    end;   
  end 
  else 
    result:=No_More_Rows; 
  sproc_retcode:=result; 
end; 
 
function Tsybquery.column(index:byte):string; 
begin 
  result:=strpas(dbvalue(dbproc,index)) 
end; 
 
function Tsybquery.heading(index:byte):string; 
begin 
  result:=strpas(dbcolname(dbproc,index)) 
end; 
 
function Tsybquery.coltype(index:byte):string; 
begin 
  result:=strpas(dbprtype(dbcoltype(dbproc,index))) 
end; 
 
function Tsybquery.collength(index:byte):integer; 
begin 
  result:=dbcollen(dbproc,index) 
end; 
 
function Tsybquery.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 
{  SqlCommand:array[0..8000] of char;} 
  Login,Retcode,retcode2,i:integer; 
  dbname :SybObjectname; 
  s      :string; 
  tslist:Tsybquery; 
  adatabase :tsybdatabase; 
begin 
  tslist:=Tsybquery(getcomponent(0)); 
 
  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 
end; 
 
function Tsybobjectproperty.getattributes:Tpropertyattributes; 
begin 
  Result := [paValueList,paAutoUpdate,paMultiSelect]; 
end; 
 
procedure tsybquery.get_dbproc; 
var i         :integer; 
    adatabase :tsybdatabase; 
begin 
  if not autodbproc then 
    exit; 
  if sybase_components.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; 
  OKBottomDlg.free; 
end; 
 
function Tstringsproperty.getattributes:Tpropertyattributes; 
begin 
  result:=[padialog]; 
end; 
 
procedure Tsybquery.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 Tsybquery.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 TSybQuery.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)) 
           and (length(name)>0) and (length(heading(i))>0) then 
          begin 
            tsybfield(fieldslist[j]).value:=column(i); 
          end; 
        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)) 
           and (length(name)>0) and (length(heading(i))>0) 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)) 
           and (length(name)>0) and (length(heading(i))>0) 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)) 
           and (length(name)>0) and (length(heading(i))>0) then 
          tsybradiobutton(fieldslist[j]).value:=column(i); 
        end; 
      end; 
    end; 
 
  end; 
end; 
 
procedure tsybquery.get_databasefields; 
var tmpquery :tsybquery; 
    i        :integer; 
begin 
 
  get_dbproc; 
  tmpquery:=tsybquery.create(nil); 
  tmpquery.dbname:=dbname; 
  tmpquery.dbproc:=dbproc; 
  tmpquery.sql:=fdesignsql; 
  datafieldscount:=0; 
  tmpquery.sqlexec; 
  for i:=1 to tmpquery.numcols do 
  begin 
    inc(datafieldscount); 
    datafields[datafieldscount]:=tmpquery.heading(i); 
  end; 
  tmpquery.free; 
end; 
 
procedure tsybquery.LoadSqlFromFile(FileName :string); 
begin 
  clearsql; 
  sql:=sybase_components.LoadFromFile(FileName); 
end; 
 
procedure TSybQuery.get_next_resultset; 
var linenum,i,j,rows  :integer; 
    p                 :pchar; 
begin 
  FCurrCmd:=dbcurcmd(dbProc); 
  Retcode:=dbresults(dbProc); 
  rows:=dbrows(dbProc); 
  if rows = fail then 
    setrowsreturned(false) 
  else 
    setrowsreturned(true); 
  numcols:=dbnumcols(dbProc); 
  FColumncount:=numcols; 
 
  retcode2:=0; 
  if retcode = Succeed then 
  begin 
    firstrownum:=1; 
    lastrownum:=1; 
  end; 
 
end; 
 
end.