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

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.