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

unit sybdatabase; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
  Dialogs,DsgnIntf,sybase32,sybase_components; 
 
type 
  SybObjectname = string[30]; 
  String255     = string[255]; 
 
type 
  Tsybobjectproperty = class(Tstringproperty) 
  public 
    procedure GetValues(TheProc: TGetStrProc); override; 
    function getattributes:Tpropertyattributes; override; 
  end; 
 
type 
  TSybDatabase = class(TComponent) 
  private 
    { Private declarations } 
    FUserName    :SybObjectname; 
    FDBName      :SybObjectname; 
    FPassword    :SybObjectname; 
    FServerName  :SybObjectname; 
    FLoginPrompt :boolean; 
    FServerPrompt:boolean; 
    FServerShow  :boolean; 
    FShowmessage :boolean; 
    FConnected   :boolean; 
    FBuffersize  :integer; 
    FServerList  :TStrings; 
    FDbLibVersion:string; 
    FDbVersion   :string; 
    fcharset     :SybObjectname; 
    fservercharset :SybObjectname; 
    flanguage    :SybObjectname; 
    fappname     :SybObjectname; 
    fhostname    :SybObjectname; 
    fdebugfile   :string255; 
    Ftimeout     :Integer; 
    FLoginTimeOut:Integer; 
    procedure SetTimeOut(Value :Integer); 
    procedure SetLoginTimeOut(Value :Integer); 
    procedure SetUserName(Value :SybObjectname); 
    procedure SetPassword(Value :SybObjectname); 
    procedure SetDBName(Value :SybObjectname); 
    procedure SetServerName(Value :SybObjectname); 
    procedure SetLoginPrompt(Value :boolean); 
    procedure SetServerPrompt(Value :boolean); 
    procedure SetServerShow(Value :boolean); 
    procedure SetConnected(Value :boolean); 
    procedure SetShowmessage(Value :boolean); 
    procedure SetBuffersize(Value :integer); 
    procedure SetServerList(Value:TStrings); 
    procedure SetCharset(Value:SybObjectname); 
    procedure SetLanguage(Value:SybObjectname); 
    procedure SetAppName(Value:SybObjectname); 
    procedure SetHostName(Value:SybObjectname); 
    procedure SetDebugFile(Value:String255); 
  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; 
    dbproc:integer; 
    servlist    :tstrings; 
    constructor create(AOwner:TComponent); override; 
    destructor destroy; override; 
    procedure setname(const NewName:Tcomponentname); override; 
    procedure loaded; override; 
    procedure CanQuery; 
  published 
    { Published declarations } 
    procedure connect; 
    procedure disconnect; 
    procedure get_servers; 
    property TimeOut :Integer read FTimeOut write SetTimeOut; 
    property LoginTimeOut :Integer read FLoginTimeOut write SetLoginTimeOut; 
    property DbLibVersion:string read fdblibversion; 
    property ServerCharSet:SybObjectname read fservercharset; 
    property CharSet:SybObjectname read fcharset write SetCharset; 
    property Language:SybObjectname read flanguage write SetLanguage; 
    property AppName:SybObjectname read fappname write SetAppName; 
    property HostName:SybObjectname read fhostname write SetHostName; 
    property DebugFile:string255 read fdebugfile write SetDebugFile; 
    property DBVersion:string read fdbversion; 
    property Password :SybObjectname read FPassword write SetPassword; 
    property UserName :SybObjectname read FUserName write SetUserName; 
    property DBName :SybObjectname read FDBName write SetDBName; 
    property ServerName :SybObjectname read FServerName write SetServerName; 
    property LoginPrompt :boolean read Floginprompt write Setloginprompt default True; 
    property ServerPrompt :boolean read FServerPrompt write SetServerPrompt default True; 
    property ServerShow :boolean read FServerShow write SetServerShow default True; 
    property Connected :boolean read FConnected write SetConnected stored false; 
    property ShowMessage :boolean read Fshowmessage write Setshowmessage default false; 
    property BufferSize :integer read FBuffersize write SetBuffersize; 
    property ServerList:TStrings read FServerList write FServerList; //SetServerList; 
  end; 
 
procedure Register; 
 
var from_create :boolean; 
 
implementation 
uses objectlistdlg, 
     sybaselogin, 
     sybquery; 
 
procedure Register; 
begin 
  RegisterPropertyEditor(TypeInfo(SybObjectname),TSybDatabase,'DBName',TsybobjectProperty); 
  RegisterPropertyEditor(TypeInfo(SybObjectname),TSybDatabase,'ServerName',TsybobjectProperty); 
  RegisterComponents('Sybase DBLIB', [TSybDatabase]); 
end; 
 
constructor TSybDatabase.create(AOwner:TComponent); 
var p:pointer; 
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; 
  Fserverprompt:=True; 
  Fservershow:=True; 
  FConnected:=False; 
  dbConnected:=False; 
  FDBName:='master'; 
  FBuffersize:=0; 
  fdblibversion:=''; 
  fdbversion:=''; 
  fcharset:=''; 
  fservercharset:=''; 
  from_create:=true; 
  if FirstDatabase = 0 then 
  begin 
    DatabasesList:= TList.Create; 
    FirstDatabase:=1; 
  end; 
 
  fserverlist:=tstringlist.create; 
  servlist:=tstringlist.create; 
  get_servers; 
  setserverlist(servlist); 
end; 
 
destructor TSybDatabase.destroy; 
var i :integer; 
begin 
  databaseslist.remove(self); 
  FServerList.Free; 
  ServList.Free; 
   
  inherited destroy; 
end; 
 
procedure TSybDatabase.loaded; 
begin 
  inherited loaded; 
  setserverlist(servlist); 
end; 
 
procedure TSybDatabase.setname(const NewName:Tcomponentname); 
var oldname   :Tcomponentname; 
    i         :integer; 
    adatabase :tsybdatabase; 
begin 
  oldname:=name; 
  inherited setname(NewName); 
 
  if databaseslist.indexof(self) = -1 then 
    databaseslist.add(self) 
  else 
  begin 
    databaseslist.items[databaseslist.indexof(self)]:=self; 
  end; 
end; 
 
procedure TSybDatabase.SetCharset(Value:SybObjectname); 
begin 
  fCharset:=value; 
end; 
 
procedure TSybDatabase.SetLanguage(Value:SybObjectname); 
begin 
  fLanguage:=value; 
end; 
 
procedure TSybDatabase.SetAppName(Value:SybObjectname); 
begin 
  fappname:=value; 
end; 
 
procedure TSybDatabase.SetHostName(Value:SybObjectname); 
begin 
  fhostname:=value; 
end; 
 
procedure TSybDatabase.SetDebugFile(Value:String255); 
begin 
  fdebugfile:=value; 
end; 
 
procedure TSybDatabase.SetServerList(Value :TStrings); 
begin 
  FServerList.assign(Value); 
end; 
 
procedure TSybDatabase.SetUserName(Value :SybObjectname); 
begin 
  FUserName:=Value; 
end; 
 
procedure TSybDatabase.SetDBName(Value :SybObjectname); 
begin 
  FDBName:=Value; 
  strpcopy(dbase,fdbname); 
  Retcode := dbuse(dbProc,@dBase); 
end; 
 
procedure TSybDatabase.SetServerName(Value :SybObjectname); 
begin 
  FServerName:=Value; 
end; 
 
procedure TSybDatabase.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); 
  end; 
  dispose(p); 
end;   
 
procedure TSybDatabase.SetPassword(Value :SybObjectname); 
begin 
  FPassword:=Value; 
end; 
 
procedure TSybDatabase.SetLoginPrompt(Value :boolean); 
begin 
  FLoginPrompt:=Value; 
end; 
 
procedure TSybDatabase.SetServerPrompt(Value :boolean); 
begin 
  FServerPrompt:=Value; 
end; 
 
procedure TSybDatabase.SetServerShow(Value :boolean); 
begin 
  FServerShow:=Value; 
end; 
 
procedure TSybDatabase.Setshowmessage(Value :boolean); 
begin 
  Fshowmessage:=Value; 
end; 
 
procedure TSybDatabase.SetConnected(Value :boolean); 
begin 
  if not Fconnected then 
    connect 
  else 
    disconnect; 
end; 
 
procedure TSybDatabase.connect; 
var 
  usernm      :pchar; 
  PasswordDlg :TPasswordDlg; 
  q           :tsybquery; 
 
  the_set    :array[0..30] of char; 
  the_file   :array[0..255] of char; 
 
begin 
  if Fconnected then 
    exit; 
  if length(FDBName) = 0 then 
    FDBName:='master'; 
  passworddlg:=TPasswordDlg.create(nil); 
  if loginprompt then 
  begin 
    if length(FServerName) > 0 then 
      passworddlg.caption:='Login to ' + FServerName; 
    if not FServerPrompt then 
      passworddlg.server.enabled:=false; 
 
    if not FServerShow then 
    begin 
      passworddlg.server.visible:=false; 
      passworddlg.label3.visible:=false; 
      passworddlg.username.top:=9; 
      passworddlg.username.left:=84; 
      passworddlg.password.top:=43; 
      passworddlg.password.left:=84; 
      passworddlg.label2.top:=17; 
      passworddlg.label1.top:=49; 
      passworddlg.label1.left:=20; 
      passworddlg.label2.left:=36; 
      passworddlg.bevel1.height:=73; 
      passworddlg.height:=140; 
      passworddlg.okbtn.top:=82; 
      passworddlg.cancelbtn.top:=82; 
    end; 
 
    passworddlg.username.text:=FUserName; 
    passworddlg.password.text:=FPassword; 
    passworddlg.Server.text:=FServerName; 
    passworddlg.server.items:=fserverlist; 
    passworddlg.showmodal; 
    if passworddlg.modalresult = mrcancel then 
    begin 
      FConnected:=false; 
      dbConnected:=false; 
      exit; 
    end; 
    FUserName:=passworddlg.username.text; 
    FPassword:=passworddlg.password.text; 
    FServerName:=passworddlg.server.text; 
  end; 
  passworddlg.free; 
 
  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; 
 
//     1 - Host Name 
//      2 - User Name 
//      3 - Password 
//      4 - Don't know yet 
//      5 - Application Name 
//      6 - Don't know yet 
//      7 - Default Language 
//      10 - Default Charcter Set 
 
    if length(hostname)>0 then 
    begin 
      strpcopy(the_set,hostname); 
      Retcode := dbsetlname(login,@the_set,1); 
    end; 
    Retcode := dbsetlname(login,@User,2); 
    Retcode := dbsetlname(login,@Pwd,3); 
    if length(appname)>0 then 
    begin 
      strpcopy(the_set,appname); 
      Retcode := dbsetlname(login,@the_set,5); 
    end; 
    if length(language)>0 then 
    begin 
      strpcopy(the_set,language); 
      Retcode := dbsetlname(login,@the_set,7); 
    end; 
    if length(charset)>0 then 
    begin 
      strpcopy(the_set,charset); 
      Retcode := dbsetlname(login,@the_set,10); 
    end; 
    if length(debugfile)>0 then 
    begin 
      strpcopy(the_file,debugfile); 
      dbrecftos(@the_file); 
    end; 
    Retcode:=dbSetlBool(Login, 1, 6); 
    dbProc := dbopen(login,server); 
    If dbProc <> 0 then 
    Begin 
      retcode:=dbuse(dbProc,@dBase); 
      FConnected:=true; 
      dbConnected:=true; 
      dbprocc:=dbproc; 
      setbuffersize(buffersize); 
      fdblibversion:=dbversion; 
      fcharset:=dbgetcharset(dbproc); 
      fservercharset:=dbservcharset(dbproc); 
      fLanguage:=dbgetnatlang(dbproc); 
 
      q:=tsybquery.create(nil); 
      q.AutoDbProc:=false; 
      q.dbproc:=dbprocc; 
      q.dbname:=name; 
      q.sql:='select @@version'; 
      q.sqlexec; 
      while q.nextrow = -1 do 
      begin 
        fdbversion:=q.column(1); 
      end; 
      q.free; 
 
      if databaseslist.indexof(self) = -1 then 
        databaseslist.add(self) 
      else 
        databaseslist.items[databaseslist.indexof(self)]:=self; 
    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); 
    FConnected:=false; 
    dbConnected:=false; 
  end; 
  dbloginfree(login); 
 
end; 
 
procedure TSybDatabase.disconnect; 
begin 
  if Fconnected then 
  begin 
    FConnected:=false; 
    dbConnected:=false; 
    dbclose(dbProc); 
{    dbexit;} 
  end; 
end; 
 
procedure Tsybobjectproperty.GetValues(TheProc: TGetStrProc); 
var 
  SqlCommand:array[0..2048] of char; 
  Login,Retcode,retcode2:integer; 
  dbname :SybObjectname; 
  proc,i :integer; 
  tslist :tsybdatabase; 
begin 
  tslist:=tsybdatabase(getcomponent(0)); 
  proc:=tslist.dbproc; 
 
  if getname='ServerName' then 
  begin 
    for i:=0 to tslist.fserverlist.count-1 do 
      theproc(tslist.fserverlist[i]); 
  end; 
 
  if getname='DBName' then 
  begin 
    if tslist.dbconnected then 
    begin 
      strpcopy(Sqlcommand,'select name from master..sysdatabases'); 
      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; 
 
  strpcopy(tslist.dbase,getstrvalue); 
  retcode:=dbuse(Proc,@tslist.dbase); 
end; 
 
function Tsybobjectproperty.getattributes:Tpropertyattributes; 
begin 
  Result := [paValueList,paAutoUpdate,paMultiSelect]; 
end; 
 
procedure TSybDatabase.get_servers; 
var sybase_dir  :array[0..255] of char; 
    fin         :textfile; 
    l           :string[30]; 
    l2          :string[1]; 
begin 
    GetEnvironmentVariable('SYBASE',sybase_dir,sizeof(sybase_dir)); 
    l:=string(sybase_dir) + '\INI\SQL.INI'; 
    try 
    assignfile(fin,l); 
    {$i-} reset(fin) {$i+}; 
    if (ioresult=0) then 
    begin 
 
      while not eof(fin) do 
      begin 
        readln(fin,l); 
        l2:=l; 
        if l2='[' then 
        begin 
          ServList.add(copy(l,2,length(l)-2)); 
        end; 
      end; 
    end; 
    finally 
    {$i-} closefile(fin) {$i+}; 
    end; 
end; 
 
procedure TSybDatabase.CanQuery; 
begin 
  Dbcanquery(dbProcc); 
end; 
 
procedure TSybDatabase.SetLoginTimeOut(Value: Integer); 
var retcode   :Integer; 
begin 
  retcode:=dbsetlogintime(Value); 
  FLoginTimeOut:=Value; 
end; 
 
procedure TSybDatabase.SetTimeOut(Value: Integer); 
var retcode   :Integer; 
begin 
  retcode:=dbsettime(Value); 
  FTimeOut:=Value; 
end; 
 
end.