sybcombobox.pas

sybase大全

unit sybcombobox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,DsgnIntf;

type
  SybObjectname = string[30];
  string30      = 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
  TSybComboBox = class(TComboBox)
  private
    { Private declarations }
    FSql         :ansistring;
    FTablename   :SybObjectname;
    Ffieldname   :SybObjectname;
    FDbname      :SybObjectname;
    FDesignActive:boolean;
    FRowsReturned:boolean;
    FAutoDbProc  :boolean;
    FAutoSize    :boolean;
    FDbProc      :integer;
    fcomp_type   :string30;
    procedure SetAutoDbProc(Value :boolean);
    procedure SetAutoSize(Value :boolean);
    procedure SetDbProc(Value :integer);
    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;
    procedure setvalue(value:string);
  protected
    { Protected declarations }
    procedure get_dbproc;
  public
    { Public declarations }
    SqlCommand:array[0..4096] of char;
    Login,Retcode,retcode2,nocols,col:integer;
    dbprocc:integer;
    tablenm,fieldnm:SybObjectname;
    property comp_type:string30 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 LoadSqlFromFile(FileName :string);
  published
    { Published declarations }
    property DbName :SybObjectname read FDbName write setDbname;
    property Sql :ansistring read FSql write SetSql;
    property TableName :SybObjectname read FTableName write settablename;
    property FieldName :SybObjectname read FFieldName write setfieldname;
    property AutoDbProc:boolean read FAutoDbProc write SetAutoDbProc default true;
    property AutoSize:boolean read FAutoSize write SetAutoSize default false;
    property DesignActive:boolean read fdesignactive write setdesignactive stored false;
    property RowsReturned:boolean read fRowsReturned write setRowsReturned default false;
    property DbProc:integer read FDbproc write SetDbProc default 0;
    property Value:string read getvalue write setvalue;
  end;

procedure Register;

implementation
uses sybase32,
     objectlistdlg,
     ansistringedit,
     sybase_components,
     sybdatabase;

procedure Register;
begin
  RegisterPropertyEditor(TypeInfo(SybObjectname),Tsybcombobox,'',Tsybobjectproperty);
  RegisterPropertyEditor(TypeInfo(AnsiString),TSybComboBox,'Sql',TstringsProperty);
  RegisterComponents('Sybase DBLIB', [Tsybcombobox]);
end;

constructor Tsybcombobox.create(AOwner:TComponent);
begin
  inherited create(AOwner);
  fcomp_type:='combobox';
  text:='';
  Fdesignactive:=false;
  Fautodbproc:=true;
  Fautosize:=false;
  Fdbproc:=0;
  if sybase_components.comboboxList = nil then
  begin
    sybase_components.comboboxlist:=TList.create;
  end;
end;

destructor tsybcombobox.destroy;
begin
  comboboxlist.remove(self);
  inherited destroy;
end;

function TSybcombobox.getvalue:string;
begin
  result:=text;
end;

procedure TSybcombobox.setvalue(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;
  text:=value;
end;

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

procedure TSybcombobox.SetAutoDbPRoc(Value :boolean);
begin
  FAutoDbProc:=value;
end;

procedure TSybcombobox.SetAutoSize(Value :boolean);
begin
  FAutoSize:=value;
end;

procedure tsybcombobox.SetDbProc(Value :integer);
begin
  FDbproc:=Value;
  Dbprocc:=Value;
end;

procedure Tsybcombobox.SetSql(Value :ansistring);
begin
  FSql:=Value;
end;

procedure Tsybcombobox.SetRowsReturned(Value:boolean);
begin
  FRowsReturned:=value;
end;

procedure Tsybcombobox.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 Tsybcombobox.addsql(Value :ansistring);
begin
  FSql:=FSql + Value;
end;

procedure Tsybcombobox.clearsql;
begin
  FSql:='';
end;

function Tsybcombobox.sqlexec:integer;
var value    :string[255];
    rows     :integer;
    p        :pchar;
    maxwdth  :integer;
begin
  get_dbproc;
  if dbprocc = 0 then
    exit;
  maxwdth:=round(width/font.size);
  clear;
  if length(Fsql) = 0 then
    Fsql:='select ' + FFieldName + ' from ' + FTableName;
  p:=pchar(FSql);
  Retcode := dbcmd(dbProc,p);
  Retcode := Dbsqlexec(dbProcc);
  Retcode := dbresults(dbProcc);

  rows:=dbrows(dbProc);
  if rows = fail then
    setrowsreturned(false)
  else
    setrowsreturned(true);

  Result:=retcode;
  retcode2:=0;
  while (retcode <> No_more_results) and (retcode <> Fail) do
  begin
    if retcode = Succeed then
    begin
      retcode2 := dbnextrow(dbProcc);
      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;
        items.add(strpas(dbvalue(dbProcc,1)));
        retcode2 := dbnextrow(dbProcc);
        result:=retcode2;
      end;
    end;
    Retcode := dbresults(dbprocc);
  end;
  if fautosize then
  begin
    width:=maxwdth * font.size+10;
  end;
  if items.count>0 then
  begin
    itemindex:=0;
  end;
end;

procedure Tsybcombobox.Settablename(Value :SybObjectname);
begin
  Ftablename:=value;
  tablenm:=value;
end;

procedure Tsybcombobox.Setfieldname(Value :SybObjectname);
begin
  Ffieldname:=value;
  fieldnm:=value;
end;

procedure Tsybcombobox.SetDbname(Value :SybObjectname);
begin
  FDbname:=value;
  get_dbproc;
end;

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

procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc);
var
  SqlCommand:array[0..4096] of char;
  Login,Retcode,retcode2,i:integer;
  dbname    :SybObjectname;
  s         :string[255];
  proc      :integer;
  tslist    :tsybcombobox;
  adatabase :tsybdatabase;
begin
  tslist:=tsybcombobox(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 Tsybcombobox.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
  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;

end.