ufundserver.pas

Delphi Com编程的简单例子

unit uFundServer;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComServ, ComObj, VCLCom, StdVcl, bdemts, DataBkr, DBClient, IniFiles,
  MtsRdm, Mtx, FundCom_TLB, ADODB, Provider, DB;

const
  INIFILENAME = 'system.ini';
  INIFUND = 'SysCom';
  INISERVER = 'ServerName';
  INIDATABASE = 'DatabaseName';
  INIUSER = 'Admin';
  INIPWD = 'connect';

type
  TFundServer = class(TMtsDataModule, IFundServer)
    Conn_Fund: TADOConnection;
    ads_Fund: TADODataSet;
    dsp_Fund: TDataSetProvider;
    cds_Fund: TClientDataSet;
    sp_Fund: TADOStoredProc;
    sq_Fund: TADOQuery;
    dsp_Qry: TDataSetProvider;
    cds_Qry: TClientDataSet;
    adc_Fund: TADOCommand;
    procedure MtsDataModuleCreate(Sender: TObject);
  private
    { Private declarations }
    function F_Connect(const cServer, cDB, cUser, cPwd: string): boolean;
    function ConnectServer(const cSystem: string): string;
    function ConnectDatabase(const cSystem: string): string;
    function ConnectUser(const cSystem: string): string;
    function ConnectPWD(const cSystem: string): string;

    function ReadIniStr(const Files, Section, IDent: string): string;
    function ReadIniInt(const Files, Section, IDent: string): integer;
    function SystemPath: string;
  protected
    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID:
      string); override;
    procedure ReConnect(var lResult: Integer); safecall;

    procedure FreeQuery(const cSqlStr: WideString; var vData: OleVariant);
      safecall;
    procedure ExeSqlCmd(const cSqlStr: WideString; var lResult: Integer);
      safecall;

    procedure LogAdd(V02: Smallint; const V04, V05, V06, V07: WideString;
      var lResult: Integer); safecall;
    procedure LogDel(const V01: WideString; var lResult: Integer); safecall;

    //用户组管理
    procedure UserGrpAdd(var V01: WideString; const V02, V03: WideString;
      V04: Smallint; var lResult: Integer); safecall;
    procedure UserGrpDel(const V01: WideString; var lResult: Integer);
      safecall;
    procedure UserGrpUpd(const V01, V02, V05: WideString;
      var lResult: Integer); safecall;

    //用户管理
    procedure UserAdd(var V01: WideString; const V02, V03, V04: WideString;
      V08, V09: Smallint; const V10, V11: WideString; V12, V13, V14,
      V16: Smallint; const V17: WideString; V18, V19: Smallint;
      const V20: WideString; var lResult: Integer); safecall;
    procedure UserDel(const V01: WideString; var lResult: Integer); safecall;
    procedure UserUpd(const V01, V02, V03, V04: WideString; V08, V09: Smallint;
      const V10, V11: WideString; V12, V13, V14, V16: Smallint;
      const V17: WideString; V18, V19: Smallint; const V20: WideString;
      var lResult: Integer); safecall;

    //子系统模块删除
    procedure SubModDel(const V01, V02: WideString; var lResult: Integer);
      safecall;

    //子系统删除
    procedure SubSysDel(const V01: WideString; var lResult: Integer); safecall;

    //子系统管理员权限修改
    procedure SubRightAdd(const V01: WideString; V03, V04, V05, V06, V07,
      V08: Smallint; var lResult: Integer); safecall;

    //子系统管理员更换
    procedure SubRightChg(const V01, V02, V021: WideString;
      var lResult: Integer); safecall;

    //权限组删除
    procedure RightGrpDel(const V01: WideString; var lResult: Integer);
      safecall;

    //组权限管理
    procedure GrpRightAdd(const V01, V02, V03: WideString;
      var lResult: Integer); safecall;
    procedure GrpRightDel(const V01: WideString; var lResult: Integer);
      safecall;

    //用户权限管理
    procedure UserRightAdd(const V01, V02, V03: WideString;
      var lResult: Integer); safecall;
    procedure UserRightDel(const V01: WideString; var lResult: Integer);
      safecall;

    //组权限变更
    procedure GrpRightChg(const V01: WideString; var lResult: Integer);
      safecall;
    //用户权限变更
    procedure UserRightChg(const V01: WideString; var lResult: Integer);
      safecall;

    //添加用户到用户组
    procedure UserToGrp(const V01, V02: WideString; var lResult: Integer);
      safecall;

    //用户组用户删除
    procedure GrpUserDel(const V02: WideString; var lResult: Integer);
      safecall;

    //口令卡组管理
    procedure CardGrpAdd(var V01: WideString; const V02, V03: WideString;
      V04: Smallint; var lResult: Integer); safecall;
    procedure CardGrpDel(const V01: WideString; var lResult: Integer);
      safecall;
    procedure CardGrpUpd(const V01, V02, V05: WideString;
      var lResult: Integer); safecall;

    //口令卡管理
    procedure CardAdd(var V01: WideString; const V02: WideString;
      var lResult: Integer); safecall;
    procedure CardDel(const V01: WideString; var lResult: Integer); safecall;
    procedure CardUpd(const V01, V02, V03, V04, V05: WideString; V06,
      V07: Smallint; const V08: WideString; var lResult: Integer);
      safecall;

    //口令卡值 管理
    procedure CardValAdd(const V01, V02, V03, V04: WideString;
      var lResult: Integer); safecall;
    procedure CardValDel(const V01: WideString; var lResult: Integer);
      safecall;

    //用户IP管理
    procedure UserIPDel(const V01: WideString; var lResult: Integer); safecall;
    procedure UserIPAdd(const V01, V02: WideString; var lResult: Integer);
      safecall;

    //用户登录
    procedure SysLogin(const LoginName, PWD: WideString; var lResult: Integer);
      safecall;
    procedure UserLogin(const LoginName, PWD, LabA, ValA, LabB, ValB, UCard,
      IPAdd: WideString; var lResult: Integer); safecall;

    procedure SubSysLogin(const SubSysId, LoginName, PWD, LabA, ValA, LabB,
      ValB, UCard, IPAdd: WideString; var lResult: Integer); safecall;

    //查询系统用户
    procedure QSysUser(const SysId, cSql: WideString; var vData: OleVariant);
      safecall;
      
    //查询不在此系统的用户
    procedure QNotSysUser(const SysId, cSql: WideString;
      var vData: OleVariant); safecall;

    //添加用户到子系统
    procedure UserToSys(const V01, V02: WideString; var lResult: Integer);
      safecall;

    //写日志
    procedure Log(LogType: Smallint; const SubSysId, UserId,
      IpAddr: WideString; var lResult: Integer); safecall;

  public
    { Public declarations }
  end;

var
  FundServer: TFundServer;

implementation

{$R *.DFM}

class procedure TFundServer.UpdateRegistry(Register: Boolean; const ClassID,
  ProgID: string);
begin
  if Register then
  begin
    inherited UpdateRegistry(Register, ClassID, ProgID);
    EnableSocketTransport(ClassID);
    EnableWebTransport(ClassID);
  end
  else
  begin
    DisableSocketTransport(ClassID);
    DisableWebTransport(ClassID);
    inherited UpdateRegistry(Register, ClassID, ProgID);
  end;
end;

procedure TFundServer.MtsDataModuleCreate(Sender: TObject);
begin
  F_Connect(ConnectServer(INIFUND), ConnectDatabase(INIFUND), INIUSER, INIPWD);
end;

function TFundServer.ConnectDatabase(const cSystem: string): string;
begin
  Result := ReadIniStr(SystemPath() + INIFILENAME, cSystem, INIDATABASE);
end;

function TFundServer.ConnectPWD(const cSystem: string): string;
begin
  Result := ReadIniStr(SystemPath() + INIFILENAME, cSystem, INIPWD);
end;

function TFundServer.ConnectServer(const cSystem: string): string;
begin
  Result := ReadIniStr(SystemPath() + INIFILENAME, cSystem, INISERVER);
end;

function TFundServer.ConnectUser(const cSystem: string): string;
begin
  Result := ReadIniStr(SystemPath() + INIFILENAME, cSystem, INIUSER);
end;

function TFundServer.F_Connect(const cServer, cDB, cUser,
  cPwd: string): boolean;
begin
  result := False;
  if Conn_Fund.Connected then
    Conn_Fund.Close;
  Conn_Fund.ConnectionString := 'Provider=SQLOLEDB.1;Password=' + cPwd +
    ';User ID=' + cUser + ';Initial Catalog=' + cDB + ';Data Source=' + cServer;
  try
    Conn_Fund.Open();
    result := True;
  except
    result := False;
  end;
end;

function TFundServer.ReadIniInt(const Files, Section,
  IDent: string): integer;
var
  mIni: tIniFile;
  iItem: integer;
begin
  iItem := 0;
  if FileExists(Files) then
  begin
    mIni := tIniFile.Create(Files);
    iItem := mIni.ReadInteger(Section, iDent, 0);
    mIni.Free;
  end;
  Result := iItem;
end;

function TFundServer.ReadIniStr(const Files, Section,
  IDent: string): string;
var
  mIni: tIniFile;
  cItem: string;
begin
  cItem := '';
  if FileExists(Files) then
  begin
    mIni := tIniFile.Create(Files);
    cItem := mIni.ReadString(Section, Ident, '');
    mIni.Free;
  end;
  Result := cItem;
end;

function TFundServer.SystemPath: string;
var
  cSysPath: Pchar;
  cPath: string;
begin
  cSysPath := StrAlloc(sizeof(char) * 255);
  GetSystemDirectory(cSysPath, 200);
  cPath := trim(cSysPath);
  StrDispose(cSysPath);
  if copy(cPath, length(cPath), 1) <> '\' then
    cPath := cPath + '\';
  result := cPath;
end;

procedure TFundServer.FreeQuery(const cSqlStr: WideString;
  var vData: OleVariant);
begin
  cds_Fund.Active := false;
  cds_Fund.CommandText := cSqlStr;
  try
    try
      cds_Fund.Active := true;
      vData := cds_Fund.XMLData;
    finally
      cds_Fund.Active := false;
    end;
    SetComplete;
  except
    on Exception do
      SetAbort;
  end;
end;

procedure TFundServer.ExeSqlCmd(const cSqlStr: WideString;
  var lResult: Integer);
begin
  adc_Fund.CommandText := cSqlStr;
  try
    adc_Fund.Prepared;
    adc_Fund.Execute;
    lResult := 0;
    SetComplete;
  except
    on Exception do
    begin
      lResult := 1;
      SetAbort;
    end;
  end;
end;

procedure TFundServer.LogAdd(V02: Smallint; const V04, V05, V06,
  V07: WideString; var lResult: Integer);
begin
  try
    if sp_Fund.Active = true then
      sp_Fund.Close;
    sp_Fund.ProcedureName := 'p_099_Add';
    sp_Fund.Parameters.Refresh;
    with sp_Fund.Parameters do
    begin
      ParamByName('@V02').Value := V02;
      ParamByName('@V04').Value := V04;
      ParamByName('@V05').Value := V05;
      ParamByName('@V06').Value := V06;
      ParamByName('@V07').Value := V07;
      ParamByName('@ret').Value := -1;
    end;
    sp_Fund.ExecProc;
    lResult := sp_Fund.Parameters.ParamByName('@ret').Value;
    sp_Fund.Close;
    SetComplete;
  except
    on Exception do
      SetAbort;
  end;
end;

procedure TFundServer.LogDel(const V01: WideString; var lResult: Integer);
begin
  try
    if sp_Fund.Active = true then
      sp_Fund.Close;
    sp_Fund.ProcedureName := 'p_099_Del';
    sp_Fund.Parameters.Refresh;
    with sp_Fund.Parameters do
    begin
      ParamByName('@V01').Value := V01;
      ParamByName('@ret').Value := -1;
    end;
    sp_Fund.ExecProc;
    lResult := sp_Fund.Parameters.ParamByName('@ret').Value;
    sp_Fund.Close;
    SetComplete;
  except
    on Exception do
      SetAbort;
  end;
end;

procedure TFundServer.ReConnect(var lResult: Integer);
begin
  if F_Connect(ConnectServer(INIFUND), ConnectDatabase(INIFUND), INIUSER, INIPWD)
    then
    lResult := 0 //连接成功
  else
    lResult := 5; //连接失败
end;

procedure TFundServer.UserGrpAdd(var V01: WideString; const V02,
  V03: WideString; V04: Smallint; var lResult: Integer);
begin
  try
    if sp_Fund.Active = true then
      sp_Fund.Close;
    sp_Fund.ProcedureName := 'p_003_Add';
    sp_Fund.Parameters.Refresh;
    with sp_Fund.Parameters do
    begin
      ParamByName('@V01').Value := V01;
      ParamByName('@V02').Value := V02;
      ParamByName('@V03').Value := V03;
      ParamByName('@V04').Value := V04;
      ParamByName('@ret').Value := -1;
    end;
    sp_Fund.ExecProc;
    lResult := sp_Fund.Parameters.ParamByName('@ret').Value;
    V01 := sp_Fund.Parameters.ParamByName('@V01').Value;
    sp_Fund.Close;
    SetComplete;
  except
    on Exception do
      SetAbort;
  end;
end;

procedure TFundServer.UserGrpDel(const V01: WideString;
  var lResult: Integer);
begin
  try
    if sp_Fund.Active = true then
      sp_Fund.Close;
    sp_Fund.ProcedureName := 'p_003_del';
    sp_Fund.Parameters.Refresh;
    with sp_Fund.Parameters do
    begin
      ParamByName('@V01').Value := V01;
      ParamByName('@ret').Value := -1;
    end;
    sp_Fund.ExecProc;
    lResult := sp_Fund.Parameters.ParamByName('@ret').Value;
    sp_Fund.Close;
    SetComplete;
  except
    on Exception do
      SetAbort;
  end;
end;

procedure TFundServer.UserGrpUpd(const V01, V02, V05: WideString;
  var lResult: Integer);
begin
  try
    if sp_Fund.Active = true then
      sp_Fund.Close;
    sp_Fund.ProcedureName := 'p_003_Upd';