sybdb.pas

sybase大全

unit sybdb;

interface

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

type
  SybObjectname = string[30];
  string10 = string[10];

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
  Tsybdb = class(TComponent)
  private
    { Private declarations }
    FUserName    :SybObjectname;
    FDBName      :SybObjectname;
    FPassword    :SybObjectname;
    FServerName  :SybObjectname;
    FLoginPrompt :boolean;
    FConnected   :boolean;
    FSql         :ansistring;
    FMaxCount    :integer;
    FColumnCount :integer;
    FBuffersize  :integer;
    procedure SetUserName(Value :SybObjectname);
    procedure SetDBName(Value :SybObjectname);
    procedure SetPassword(Value :SybObjectname);
    procedure SetServerName(Value :SybObjectname);
    procedure SetLoginPrompt(Value :boolean);
    procedure SetConnected(Value :boolean);
    procedure SetSql(Value :ansistring);
    procedure SetMaxCount(Value :integer);
    procedure SetBuffersize(Value :integer);
  protected
    { Protected declarations }
  public
    { Public declarations }
    dbconnected :boolean;
    dbprocc:integer;
    Server,user,pwd,dBase  :array[0..30] of char;
    Login,Retcode,retcode2,nocols,col:integer;
    MsgPointer,ErrPointer,tPointer,Adr:Pointer;
    SqlCommand:array[0..4096] of char;
    firstrownum,lastrownum,currrownum:longint;
    dbproc:integer;
    constructor create(AOwner:TComponent); override;
    destructor destroy; override;
    procedure setname(const NewName:Tcomponentname); override;
    procedure connect;
    procedure disconnect;
    procedure addsql(Value :ansistring);
    procedure clearsql;
    function sqlexec:integer;
    function nextrow:integer;
    function prevrow:integer;
    function firstrow:integer;
    function lastrow:integer;
    function column(index:byte):string;
    function heading(index:byte):string;
  published
    { Published declarations }
    property UserName :SybObjectname read FUserName write SetUserName;
    property DBName :SybObjectname read FDBName write SetDBName;
    property Password :SybObjectname read FPassword write SetPassword;
    property ServerName :SybObjectname read FServerName write SetServerName;
    property LoginPrompt :boolean read Floginprompt write Setloginprompt default True;
    property Connected :boolean read FConnected write SetConnected default false;
    property Sql :ansistring read FSql write SetSql;
    property MaxCount :integer read FMaxCount write SetMaxCount default 0;
    property ColumnCount :integer read FColumnCount;
    property BufferSize :integer read FBuffersize write SetBuffersize;
  end;

procedure Register;
var from_create :boolean;

implementation
uses sybaselogin,
     objectlistdlg,
     ansistringedit;

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

constructor Tsybdb.create(AOwner:TComponent);
begin
  inherited create(AOwner);
  ErrPointer := MakeProcInstance(GetProcAddress(0,'Errors'),hInstance);
  MsgPointer := MakeProcInstance(GetProcAddress(0,'Messages'),hInstance);
  dbmsghandle(addr(syb_messages));
  dberrhandle(addr(errors));
  Floginprompt:=True;
  FConnected:=False;
  dbConnected:=False;
  FDBName:='master';
  FBuffersize:=0;
{  inc(sybase_components.databasecount);}
  from_create:=true;
  if FirstDatabase = 0 then
  begin
    DatabasesList:= TList.Create;
    FirstDatabase:=1;
  end;
  New(ADatabase);
end;

destructor TSybDb.destroy;
begin
  inherited destroy;
{  dec(sybase_components.databasecount);}
end;

procedure TSybDb.setname(const NewName:Tcomponentname);
var oldname :Tcomponentname;
    i       :integer;
begin
  oldname:=name;
  inherited setname(NewName);
{  sybase_components.databaselist[sybase_components.databasecount]:=name;}
  if from_create then
  begin
    ADatabase^.name:=name;
    DatabasesList.Add(ADatabase);
    from_create:=false;
  end
  else
  begin

    for i:=0 to (sybase_components.databaseslist.count-1) do
    begin
      sybase_components.adatabase:=databaseslist[i];
      if sybase_components.adatabase.name = oldname then
      begin
        sybase_components.adatabase.name:=name;
        sybase_components.databaseslist.remove(sybase_components.databaseslist[i]);
        sybase_components.databaseslist.add(adatabase);
        exit;
      end;
    end;
  end;  
end;

procedure Tsybdb.SetUserName(Value :SybObjectname);
begin
  FUserName:=Value;
end;

procedure Tsybdb.SetDBName(Value :SybObjectname);
begin
  FDBName:=Value;
  strpcopy(dbase,fdbname);
  Retcode := dbuse(dbProc,@dBase);
end;

procedure Tsybdb.SetPassword(Value :SybObjectname);
begin
  FPassword:=Value;
end;

procedure Tsybdb.SetServerName(Value :SybObjectname);
begin
  FServerName:=Value;
end;

procedure Tsybdb.SetLoginPrompt(Value :boolean);
begin
  FLoginPrompt:=Value;
end;

procedure TSybDb.SetSql(Value :ansistring);
begin
  FSql:=Value;
end;
procedure TSybDb.SetMaxCount(Value :integer);
begin
  FMaxCount:=Value;
end;

procedure TSybDb.SetBuffersize(Value :integer);
var p :pchar;
    s :string[20];
begin
  FBuffersize:=Value;
  s:=inttostr(value);
  new(p);
  strpcopy(p,s);
  if (Value > 0)
    and (connected) then
  begin
    retcode:=dbsetopt(dbproc,DBBUFFER,p,-1);
    dispose(p);
  end;
end;

procedure TSybDb.addsql(Value :ansistring);
begin
  FSql:=FSql + Value;
end;

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

procedure Tsybdb.SetConnected(Value :boolean);
begin
  if not dbconnected then
    connect
  else
    disconnect;
  FConnected:=Value;
  dbConnected:=Value;
end;

procedure Tsybdb.connect;
var
  PasswordDlg :TPasswordDlg;
  usernm      :pchar;
  p           :pchar;
  s           :string[20];
  i           :integer;
begin
  if Fconnected then
    exit;
  if length(FDBName) = 0 then
    FDBName:='master';
  if loginprompt then
  begin
    passworddlg:=TPasswordDlg.create(nil);
    if length(FServerName) > 0 then
      passworddlg.caption:='Login to ' + FServerName;
    passworddlg.username.text:=FUserName;
    passworddlg.password.text:=FPassword;
    passworddlg.Server.text:=FServerName;
    passworddlg.showmodal;
    FUserName:=passworddlg.username.text;
    FPassword:=passworddlg.password.text;
    FServerName:=passworddlg.server.text;
    passworddlg.free;
  end;

  FConnected:=false;
  dbConnected:=false;

  if (passworddlg.modalresult = mrok)
    or (not loginprompt) then
  begin
    strpcopy(User,UserName);
    strpcopy(Pwd,Password);
    StrpCopy(Server,ServerName);
    StrpCopy(dBase,DBName);

    dbinit;
    login := dblogin;
    Retcode := dbsetlname(login,@User,2);
    Retcode := dbsetlname(login,@Pwd,3);

    dbProc := dbopen(login,server);
    If dbProc <> 0 then
    Begin
      retcode:=dbuse(dbProc,@dBase);
      FConnected:=true;
      dbConnected:=true;
      dbprocc:=dbproc;
      setbuffersize(buffersize);
{      for i:=1 to sybase_components.databasecount do
      begin
        if name = sybase_components.databaselist[i] then
        begin
          sybase_components.databaseprocs[i]:=dbproc;
          exit;
        end;
      end;}
      for i:=0 to (sybase_components.databaseslist.count-1) do
      begin
        sybase_components.adatabase:=databaseslist[i];
        if name = sybase_components.adatabase.name then
        begin
          sybase_components.adatabase.dbproc:=dbproc;
          sybase_components.databaseslist.remove(sybase_components.databaseslist[i]);
          sybase_components.databaseslist.add(adatabase);
          break;
        end;
      end;
    end
    else
    begin
      FConnected:=false;
      dbConnected:=false;
    end;
  end
  else
  begin
    FConnected:=false;
    dbConnected:=false;
  end;
  if not FConnected then
  begin
    MessageBox(GetActiveWindow,'Could not login to Server','DB-Library error',mb_ok+mb_iconexclamation{+mb_systemmodal});
  end;
end;

procedure Tsybdb.disconnect;
begin
  if Fconnected then
  begin
    FConnected:=false;
    dbConnected:=false;
    dbclose(dbProc);
  end;
end;

function Tsybdb.sqlexec:integer;
var value :string[255];
    p     :pchar;
begin
  if dbproc = 0 then
    exit;
  if (retcode2 <> More_Rows) then
  begin
    Retcode := Dbcancel(dbProc);
    p:=pchar(Fsql);
    Retcode := dbcmd(dbProc,p);
    Retcode := Dbsqlexec(dbProc);
    Retcode := dbresults(dbproc);
    FColumnCount := dbnumcols(dbproc);
    Result:=0;
    retcode2:=0;

    if retcode = Succeed then
    begin
      firstrownum:=1;
      lastrownum:=1;
      retcode2 := dbnextrow(dbProc);
    end;
  end;
end;

function Tsybdb.nextrow:integer;
begin
  result:=0;
  if (retcode = Succeed) then
  begin
    retcode2 := dbnextrow(dbProc);
    Result:=retcode2;
    currrownum:=dbcurrow(dbProc);
    if currrownum > lastrownum then
      lastrownum:=currrownum;
  end
  else
    result:=No_More_Rows;
end;

function Tsybdb.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);
    Result:=retcode3;
  end
  else
    result:=No_More_Rows;
end;


function Tsybdb.firstrow:integer;
var value :string[255];
    retcode3:integer;
begin
  result:=0;
  if (retcode = Succeed) then
  begin
    retcode3 := dbgetrow(dbproc,firstrownum);
    Result:=retcode3;
  end
  else
    result:=No_More_Rows;
end;

function Tsybdb.lastrow:integer;
var value :string[255];
    retcode3:integer;
begin
  result:=0;
  if (retcode = Succeed) then
  begin
    retcode3 := dbgetrow(dbproc,dblastrow(dbProc));
    Result:=retcode3;
  end
  else
    result:=No_More_Rows;
end;

function Tsybdb.column(index:byte):string;
begin
  result:=strpas(dbvalue(dbproc,index))
end;

function Tsybdb.heading(index:byte):string;
begin
  result:=strpas(dbcolname(dbproc,index))
end;

procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc);
var
  SqlCommand:array[0..2048] of char;
  Login,Retcode,retcode2:integer;
  dbname :SybObjectname;
  tslist :tsybdb;
begin
  tslist:=tsybdb(getcomponent(0));

  if tslist.dbconnected then
  begin
    strpcopy(Sqlcommand,'select name from master..sysdatabases');
    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;

  strpcopy(tslist.dbase,getstrvalue);
  retcode:=dbuse(tslist.dbProc,@tslist.dbase);
end;

function Tsybobjectproperty.getattributes:Tpropertyattributes;
begin
  Result := [paValueList,paAutoUpdate,paMultiSelect];
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.