初めてのサンプル蔵アップです。
ツッコミよろしくお願いします。

InterBaseへの、ユーザーの登録、削除、パスワードの変更をする関数群です。

type
  TIBProtocol = (ibpTCPIP, ibpNetBeui, ibpSpx, ibpLocal);

//-------------------------------------------------------------------------

function AddIBUser(AUserName: string; APassword: string;
                   AdbaPass : string): string; overload;

function AddIBUser(AUserName: string; APassword: string; AdbaPass : string;
                   AServer: string; AProtocol: TIBProtocol): string; overload;

function AddIBUser(AUserName: string; APassword: string): string; overload;

//-------------------------------------------------------------------------

function DeleteIBUser(AUserName: string; AdbaPass : string): string; overload;

function DeleteIBUser(AUserName: string; AdbaPass : string;
                 AServer  : string; AProtocol: TIBProtocol): string; overload;

function DeleteIBUser(AUserName: string): string; overload;

//-------------------------------------------------------------------------

function ModifyIBUser(AUserName: string; APassword: string;
                      AdbaPass : string): string; overload;

function ModifyIBUser(AUserName: string; APassword: string; AdbaPass : string;
                   AServer: string; AProtocol: TIBProtocol): string; overload;

function ModifyIBUser(AUserName: string; APassword: string): string; overload;


//=========================================================================
implementation
uses IBHeader, IBExternals, IBErrorCodes;


type
  TIBUserOperation = (ibuAdd, ibuDelete, ibuModify);


function IBUserOperation(AUserName: string; APassword: string;
  AdbaPass: string; AServer: string; AProtocol: TIBProtocol;
  AOperation: TIBUserOperation): string;
type
Tisc_func = function(status_vector : PISC_STATUS;
                    user_sec_data  : PUserSecData): ISC_STATUS; stdcall;
var
  func: Tisc_func;
  funcName : string;
  hdl : THandle;
  status: array[0..19] of ISC_STATUS;
  sec: TUserSecData;
  s: string;
  sflg: Short;
begin
  hdl := 0;
  sflg := sec_server_spec;

  if AServer <> '' then
    sec.server := PChar(AServer)
  else
    sflg := 0;

  sec.protocol      := Ord(AProtocol) + 1;
  sec.dba_user_name := 'SYSDBA';
  sec.dba_password  := PChar(AdbaPass);
  sec.user_name     := PChar(AUserName);
  sec.password      := PChar(APassword);
  sec.sec_flags     := sflg
                    or sec_password_spec
                    or sec_dba_user_name_spec
                    or sec_dba_password_spec;

  try
    hdl := LoadLibrary(IBASE_DLL);
    if (hdl <= HINSTANCE_ERROR) then
      raise Exception.Create('ライブラリのロードに失敗しました');

    case AOperation of
      ibuAdd   : funcName := 'isc_add_user';
      ibuDelete: funcName := 'isc_delete_user';
      ibuModify: funcName := 'isc_modify_user';
    end;

    @func := GetProcAddress(hdl, PChar(funcName));
    if not Assigned(func) then
      raise Exception.Create('関数のロードに失敗しました');
  //    RaiseLastWin32Error;

    func(@status, @sec);

    if ((status[0] = 1) and (status[1] <> 0)) then
      case status[1] of
        isc_usrname_too_long          : s := 'ユーザ名が長すぎます';
        isc_password_too_long         : s := 'パスワードが長すぎます';
        isc_usrname_required          : s := 'ユーザ名を指定してください';
        isc_password_required         : s := 'パスワードを指定してください';
        isc_bad_protocol              : s := 'プロトコルが無効です';
        isc_dup_usrname_found         : s := 'ユーザー名は既に存在します';
        isc_usrname_not_found         : s := 'ユーザー名が見つかりません';
        isc_error_adding_sec_record   : s := '追加中にエラーが発生しました';
        isc_error_deleting_sec_record : s := '削除中にエラーが発生しました';
        isc_error_modifying_sec_record: s := '更新中にエラーが発生しました';
        isc_error_updating_sec_db     : s := 'セキュリティデータベース' +
          '更新中にエラーが発生しました';
      end;
  finally
    FreeLibrary(hdl);
  end;
  Result := s;
end;

//----------------------------------------------------------------------------

function DeleteIBUser(AUserName: string): string;
begin
  Result := 
    IBUserOperation(AUserName,'', 'masterkey', '', ibpLocal, ibuDelete);
end;

function DeleteIBUser(AUserName: string; AdbaPass : string): string;
begin
  Result := 
    IBUserOperation(AUserName, '', AdbaPass, '', ibpLocal, ibuDelete);
end;

function DeleteIBUser(AUserName: string; AdbaPass : string;
                      AServer: string; AProtocol: TIBProtocol): string;
begin
  Result := 
    IBUserOperation(AUserName, '', AdbaPass, AServer, AProtocol, ibuDelete);
end;


//----------------------------------------------------------------------------

function AddIBUser(AUserName: string; APassword: string): string;
begin
  Result := 
    IBUserOperation(AUserName, APassword, 'masterkey', '', ibpLocal, ibuAdd);
end;

function AddIBUser(AUserName: string; APassword: string; AdbaPass : string):
  string;
begin
  Result := 
    IBUserOperation(AUserName, APassword, AdbaPass, '', ibpLocal, ibuAdd);
end;

function AddIBUser(AUserName: string; APassword: string; AdbaPass : string;
                   AServer: string; AProtocol: TIBProtocol): string;
begin
  Result := 
  IBUserOperation(AUserName, APassword, AdbaPass, AServer, AProtocol, ibuAdd);
end;

//----------------------------------------------------------------------------

function ModifyIBUser(AUserName: string; APassword: string): string;
begin
  Result := 
  IBUserOperation(AUserName, APassword, 'masterkey', '', ibpLocal, ibuModify);
end;

function ModifyIBUser(AUserName: string; APassword: string; AdbaPass : string)
:
  string;
begin
  Result := 
    IBUserOperation(AUserName, APassword, AdbaPass, '', ibpLocal, ibuModify);
end;

function ModifyIBUser(AUserName: string; APassword: string; AdbaPass : string;
                      AServer: string; AProtocol: TIBProtocol): string;
begin
  Result :=
IBUserOperation(AUserName, APassword, AdbaPass, AServer, AProtocol, ibuModify)
;
end;


以下、簡単な使用法です。
戻り値が空文字列だったら成功です。
例外を発生させるようにして、手続きにする方法と、
どっちがいいんでしょうか。（独り言です）

procedure TForm1.Button1Click(Sender: TObject);
begin
//  ShowMessage(AddIBUser('KY','1'));
//  ShowMessage(AddIBUser('KY', '1', 'masterkey'));
//  ShowMessage(AddIBUser('KY', '1', 'masterkey', '', ibpLocal));
  ShowMessage(AddIBUser('KY', '1', 'masterkey', '127.0.0.1', ibpTCPIP));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
//  ShowMessage(DeleteIBUser('KY'));
  ShowMessage(DeleteIBUser('KY' , 'masterkey'));
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  ShowMessage(ModifyIBUser('KY','2'));
end;


　　かつぼー

 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 01/01/16 -

Original document by かつぼー        氏 ID:(CQU00157)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。