sybsproc.pas

sybase大全

unit sybsproc;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  sybase_components,sybase_parameters,DsgnIntf,sybquery;

type SybObjectname = string[30];

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

type
  TParmsproperty = class(TClassProperty)
  public
    procedure edit; override;
    function getattributes:Tpropertyattributes; override;
  end;

{TSybParams=class;}

type
  TSybSproc = class(TSybQuery)
  private
    { Private declarations }
    FSprocName      :SybObjectname;
    FParams         :TSybParams;
    FReturnRows     :boolean;
    FRetColumnCount :integer;
    FDesignActive   :boolean;
    procedure SetSProcName(Value :SybObjectname);
    function getparamscount:word;
    procedure SetReturnRows(Value :boolean);
    function get_values(name :string):string;
    function GetRetColumnCount:integer;
{    function Sybase_Type(the_type : TSybFieldType):SybObjectname;}
  protected
    { Protected declarations }
    Login,retcode2,nocols,col:integer;
    dbprocc:integer;
    procedure setname(const NewName:Tcomponentname); override;
  public
    { Public declarations }
    procedure SetParamsList(Value:TSybParams);
    function NextRow:integer; override;
    function PrevRow:integer; override;
    function FirstRow:integer; override;
    function LastRow:integer; override;
    function RetColumn(index:byte):string;
    function RetColName(index:byte):string;
    function RetColType(index:byte):string;
    function RetColLength(index:byte):integer;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ParamByname(const value:string):tsybparam;
    procedure SetDesignActive(Value :boolean);
    function SqlExec:integer; override;
    procedure LoadSqlFromFile(FileName :string);
    property RetColumnCount :integer read GetRetColumnCount;
    procedure update_retfields;
  published
    { Published declarations }
    property SProcName :SybObjectname read FSProcName write setSProcname;
    property Params: TSybParams read FParams write SetParamsList;
    property ParamCount:word read getparamscount;
    property ReturnRows :boolean read FReturnRows write SetReturnRows default false;
    property DesignActive:boolean read fdesignactive write setdesignactive stored false;
  end;

procedure Register;

implementation
uses sybase32,
     u_params_edit,
     sybdatabase,
     sybcombobox,
     sybcheckbox,
     syblistbox,
     sybradiobutton,
     sybnavigator;

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(SybObjectname),tsybsproc,'',Tsybobjectproperty);
  RegisterPropertyEditor(TypeInfo(TSybParams),tsybsproc,'',TParmsproperty);
  RegisterComponents('Sybase DBLIB', [tsybsproc]);
end;

constructor tsybsproc.create(AOwner:TComponent);
begin
  inherited create(AOwner);
  fparams:=TSybParams.create;
  if sybase_components.SProcList = nil then
    sybase_components.SProclist:=TList.create;
end;

procedure tsybsproc.LoadSqlFromFile(FileName :string);
begin
  clearsql;
  sql:=sybase_components.LoadFromFile(FileName);
end;

function tsybsproc.parambyname(const value:string):tsybparam;
begin
  result:=fparams.parambyname(value);
end;

procedure TSybSProc.SetReturnRows(Value :boolean);
begin
  FReturnRows:=Value;
end;

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

procedure tsybsproc.Setdesignactive(Value :boolean);
var query     :tsybquery;
    id        :string[10];
    ft        :tsybfieldtype;
    i         :integer;
    conn      :boolean;
    adatabase :tsybdatabase;

begin
  if value then
  begin
    conn:=false;
    if databaseslist <> nil then
    begin
      for i:=0 to sybase_components.databaseslist.count-1 do
      begin
        adatabase:=databaseslist[i];
        if adatabase.name = dbname then
        begin
          if adatabase.connected then
            conn:=true;
          break;
        end;
      end;
    end;
    get_dbproc;

    params.clear;

    if conn then
    begin
      id:='';
      query:=tsybquery.create(nil);
      query.dbname:=dbname;
      query.dbproc:=dbproc;
      query.sql:='select id from sysobjects where name = "' + sprocname + '" and type="P"';
      query.sqlexec;
      while query.nextrow = -1 do
        id:=query.column(1);
      if id = '' then exit;

      query.sql:='select substring(sc.name,2,char_length(sc.name)-1),st.name from syscolumns sc,systypes st where sc.id='+id + ' and sc.type=st.type and sc.usertype=st.usertype order by colid';
      query.sqlexec;
      while query.nextrow = -1 do
      begin
        if (query.column(2)= 'intn')
          or (query.column(2)= 'tinyint')
          or (query.column(2)= 'int')
          or (query.column(2)= 'bit')
          or (query.column(2)= 'smallint') then
         ft:=ftinteger
       else
        if (query.column(2)= 'float')
          or (query.column(2)= 'decimal')
          or (query.column(2)= 'decimaln')
          or (query.column(2)= 'numericn')
          or (query.column(2)= 'real')
          or (query.column(2)= 'money')
          or (query.column(2)= 'moneyn')
          or (query.column(2)= 'smallmoney')
          or (query.column(2)= 'floatn')
          or (query.column(2)= 'numeric') then
         ft:=ftfloat
       else
        if (query.column(2)= 'datetime')
          or (query.column(2)= 'datetimn')
          or (query.column(2)= 'smalldatetime') then
         ft:=ftdatetime
       else
        if (query.column(2)= 'text') then
         ft:=fttext
       else
          if (query.column(2)= 'char')
          or (query.column(2)= 'varchar')
          or (query.column(2)= 'nvarchar')
          or (query.column(2)= 'nchar')
          or (query.column(2)= 'binary')
          or (query.column(2)= 'sysname') then
         ft:=ftchar
       else
         ft:=ftUnknown;

        params.createparam(ft,query.column(1),ptOutput);
      end;
    end;
  end;
  Fdesignactive:=Value;
{  inherited Setdesignactive(Value);}
end;

function tsybsproc.getparamscount:word;
begin
  result:=params.count;
end;

function tsybsproc.getretcolumncount:integer;
begin
  result:=dbnumrets(dbproc);
end;

procedure tsybsproc.SetParamsList(Value:TSybParams);
begin
  fparams.assign(value);
end;

procedure tsybsproc.SetSProcName(Value :SybObjectname);
begin
  FSProcname:=value;
  params.clear;
{  designactive:=true;
  designactive:=false;}
end;

procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc);
var
{  SqlCommand:array[0..8000] of char;}
  Login,Retcode,retcode2,i:integer;
  dbname    :SybObjectname;
  sprocname :SybObjectname;
  s         :string;
  query     :tsybquery;
  sybproc   :tsybsproc;
  adatabase :tsybdatabase;

begin
  sybproc:=Tsybsproc(getcomponent(0));
  if getname = 'DbName' then
  begin
    if sybase_components.databaseslist <> nil then
      for i:=0 to (sybase_components.databaseslist.count-1) do
      begin
        adatabase:=databaseslist[i];
        theproc(adatabase.name);
      end;
  end;
  if getname = 'SProcName' then
  begin
    query:=tsybquery.create(nil);
    query.dbname:=sybproc.dbname;
    query.dbproc:=sybproc.dbproc;
    query.sql:='select name from sysobjects where type="P" order by name';
    query.sqlexec;
    while query.nextrow = -1 do
      theproc(query.column(1));

  end;
end;

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

destructor TSybSProc.Destroy;
begin
  Destroying;
  FParams.Free;
  sproclist.remove(self);
  inherited Destroy;
end;

{**********************************************************}
procedure TParmsproperty.edit;
var tsproc       :tsybsproc;
    f_paramsedit :tf_paramsedit;
    i            :integer;
begin
  tsproc:=tsybsproc(getcomponent(0));
  f_paramsedit:=tf_paramsedit.create(nil);
  f_paramsedit.caption:=tsproc.name + ' Parameters';
  f_paramsedit.paramlist.assign(tsproc.fparams);
  f_paramsedit.setsproc(tsproc);
  f_paramsedit.showmodal;
  tsproc.fparams.assign(f_paramsedit.paramlist);

  f_paramsedit.free;

end;

function TParmsproperty.getattributes:Tpropertyattributes;
begin
  Result := [paAutoUpdate,padialog];
end;

function tsybsproc.sqlexec:integer;
var i            :integer;
    tmp_param    :string[31];
    the_param    :array[0..30] of char;
{    the_value    :array[0..30] of char;}
    the_sproc    :array[0..30] of char;
    tmp_comp     :tcomponent;
    the_value    :array[0..254] of char;
{Delphi 4}
    the_values   :array of array[0..30] of char;
    the_lengths  :array of integer;

{ Delphi 3}
{    the_values   :array[0..254] of array[0..30] of char;
    the_lengths  :array[0..254] of integer;}

begin
 {Delphi 4}
  SetLength(the_values,params.count);
  SetLength(the_lengths,params.count);

  for i:=0 to params.count-1 do
  begin
    tmp_comp:=tcomponent.create(self);
    tmp_comp:=owner.findcomponent(fparams.items[i].appfieldname);
    if tmp_comp <>  nil then
    begin
      fparams.items[i].value:=tsybcombobox(tmp_comp).value;
      strpcopy(the_values[i],fparams.items[i].value);
      the_lengths[i]:=255;
      case params.items[i].sybdatatype of
        SYBBINARY,
        SYBBIT,
        SYBDATETIME4,
        SYBDATETIME,
        SYBDATETIMN,
        SYBDECIMAL,
        SYBFLT8,
        SYBFLTN,
        SYBREAL,
        SYBINT1,
        SYBINT2,
        SYBINT4,
        SYBINTN,
        SYBLONGBINARY,
        SYBMONEY4,
        SYBMONEY,
        SYBMONEYN,
        SYBNUMERIC    :the_lengths[i]:=-1;

        SYBTEXT,
        SYBCHAR,
        SYBLONGCHAR,
        SYBVARBINARY,
        SYBVARCHAR   :begin
                        the_lengths[i]:=tsybcombobox(tmp_comp).maxlength;
                        if tsybcombobox(tmp_comp).maxlength= 0 then
                          the_lengths[i]:=255;
                        if length(fparams.items[i].value)=0 then
                          the_lengths[i]:=0;
                      end;
      end;
    end;
  end;

  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;
  Retcode := Dbcanquery(dbProc);

  strpcopy(the_sproc,sprocname);
  retcode:=dbrpcinit(dbproc,@the_sproc,DBRPCRECOMPILE);
  for i:=0 to params.count-1 do
  begin
    tmp_param:='@' + params.items[i].name;
    strpcopy(the_param,tmp_param);
    retcode:=dbrpcparam(dbproc,
                        @the_param,
                        params.items[i].sybreturntype,
                        params.items[i].sybdatatype,
                        -1, {MaxLen}
                        the_lengths[i], 
                        @the_values[i]);
  end;
  retcode:=dbrpcsend(dbproc);
  retcode:=dbsqlok(dbproc);
  Retcode:=dbresults(dbProc);
  numcols:=dbnumcols(dbProc);

  if (not ReturnRows) or (dbrows(dbProc)=0) then
  begin
    while nextrow = -1 do;
    update_retfields;
  end;

end;

function tsybsproc.get_values(name :string):string;
var i  :integer;
begin
  for i:=0 to fieldslist.count-1 do
  begin
    if name = tsybcombobox(fieldslist.items[i]).name then
    begin
      result:=tsybcombobox(fieldslist.items[i]).value;
      exit;
    end;
  end;
  for i:=0 to comboboxlist.count-1 do
  begin
    if name = tsybcombobox(comboboxlist.items[i]).name then
    begin
      result:=tsybcombobox(comboboxlist.items[i]).value;
      exit;
    end;
  end;
  for i:=0 to listboxlist.count-1 do
  begin
    if name = tsybcombobox(listboxlist.items[i]).name then
    begin
      result:=tsyblistbox(listboxlist.items[i]).value;
      exit;
    end;
  end;

  result:='';
end;

function tsybsproc.retcolumn(index:byte):string;
begin
  result:=strpas(dbretvalue(dbproc,index))
end;

function tsybsproc.retcolname(index:byte):string;
begin
  result:=strpas(dbretname(dbproc,index))
end;

function tsybsproc.retcoltype(index:byte):string;
begin
  result:=strpas(dbprtype(dbrettype(dbproc,index)))
end;

function tsybsproc.retcollength(index:byte):integer;
begin
  result:=dbretlen(dbproc,index)
end;

procedure TSybSProc.update_retfields;
var i,j    :integer;
    field  :tsybfield;
    the_col: string[30];
begin
  for i:=0 to params.count-1 do
  begin

    if fieldslist <> nil then
    begin
      for j:=0 to fieldslist.count-1 do
      begin
        the_col:=retcolname(i+1);
        delete(the_col,1,1);
        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybedit') then
        begin
          if (tsybfield(fieldslist[j]).dataset = name)
           and (tsybfield(fieldslist[j]).datafield = the_col) then
          begin
            tsybfield(fieldslist[j]).value:=retcolumn(i+1);
          end;
        end
        else
{        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybmemo') then
        begin
          if (tsybmemo(fieldslist[j]).dataset = name)
           and (tsybmemo(fieldslist[j]).datafield = the_col) 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 = the_col) then
          begin
            tsybcheckbox(fieldslist[j]).value:=retcolumn(i);
          end;
        end
        else
        if (lowercase(tcomponent(fieldslist.items[j]).classname)='tsybradiobutton') then
        begin
          if (tsybradiobutton(fieldslist[j]).tablename = name)
           and (tsybradiobutton(fieldslist[j]).datafield = the_col) then
          begin
            tsybradiobutton(fieldslist[j]).value:=retcolumn(i);
          end;
        end;
      end;
    end;

  end;
end;

function TSybSProc.NextRow:integer;
begin
  inherited nextrow;
  result:=sproc_retcode;
  if result=-1 then
    update_retfields;
end;

function TSybSProc.PrevRow:integer;
begin
  inherited prevrow;
  result:=sproc_retcode;
end;

function TSybSProc.FirstRow:integer;
begin
  inherited firstrow;
end;

function TSybSProc.LastRow:integer;
begin
  inherited lastrow;
end;

end.