www.pudn.com > sybase_dblib4.zip > Sybsproc.pas
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.