delphi三层DCOM架构

OStack程序员社区-中国程序员成长平台 › 门户 › 编程›综合其他

原作者: [db:作者] 来自: [db:来源] 收藏邀请

DCOM架构:

服务端开发：

采用Delphi7+SQL2008

一、创建数据库和表

[sql] view plain copy

CREATE TABLE [dbo].[tb_Department](
[FKey] [uniqueidentifier] NOT NULL,
[FName] [varchar](50) NULL,
[FAge] [varchar](50) NULL,
[FSex] [varchar](50) NULL,
[FMobile] [varchar](50) NULL,
[FRemark] [varchar](200) NULL
) ON [PRIMARY]

二、写服务端

2.1 先创建一个application

在窗体中添加Label如图显示

[delphi] view plain copy

unit ufrmMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TfrmMain = class(TForm)
lbl1: TLabel;
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
end.

2.2 File-New-Other

点击OK 在弹出的对话框中填写

名字自己根据需要填写

此时生成2个单元一个Project1_TLB 和 Unit2 单元

打开Project1_TLB 单元按F12键

在弹出的对话框中

Name就是我们要的方法名称（根据自己需要填写）GetData 获取数据

新增参数如下图

再按相同的方法添加PostData方法（保存数据）

最终结果如下图

添加后的最代码终结果

[delphi] view plain copy

unit Project1_TLB;
// ************************************************************************ //
// WARNING
// -------
// The types declared in this file were generated from data read from a
// Type Library. If this type library is explicitly or indirectly (via
// another type library referring to this type library) re-imported, or the
// 'Refresh' command of the Type Library Editor activated while editing the
// Type Library, the contents of this file will be regenerated and all
// manual modifications will be lost.
// ************************************************************************ //
// PASTLWTR : 1.2
// File generated on 2014-10-24 14:24:49 from Type Library described below.
// ************************************************************************ //
// Type Lib: D:\Delphi7\Projects\Project1.tlb (1)
// LIBID: {C6713A20-F49B-4B06-8869-9E040C912074}
// LCID: 0
// Helpfile:
// HelpString: Project1 Library
// DepndLst:
// (1) v2.0 stdole, (C:\Windows\SysWOW64\stdole2.tlb)
// (2) v1.0 Midas, (C:\Windows\SysWOW64\midas.dll)
// (3) v4.0 StdVCL, (C:\Windows\SysWOW64\stdvcl40.dll)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface
uses Windows, ActiveX, Classes, Graphics, Midas, StdVCL, Variants;
// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
// Type Libraries : LIBID_xxxx
// CoClasses : CLASS_xxxx
// DISPInterfaces : DIID_xxxx
// Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
Project1MajorVersion = 1;
Project1MinorVersion = 0;
LIBID_Project1: TGUID = '{C6713A20-F49B-4B06-8869-9E040C912074}';
IID_ITestService: TGUID = '{C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}';
CLASS_TestService: TGUID = '{82AEC5B8-E53F-4725-A24D-456FD570E355}';
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
ITestService = interface;
ITestServiceDisp = dispinterface;
// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
TestService = ITestService;
// *********************************************************************//
// Interface: ITestService
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}
// *********************************************************************//
ITestService = interface(IAppServer)
['{C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}']
procedure GetData(const Table: WideString; const Where: WideString; var Ret: OleVariant); safecall;
procedure PostData(const Table: WideString; Value: OleVariant; var Ret: OleVariant); safecall;
end;
// *********************************************************************//
// DispIntf: ITestServiceDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}
// *********************************************************************//
ITestServiceDisp = dispinterface
['{C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}']
procedure GetData(const Table: WideString; const Where: WideString; var Ret: OleVariant); dispid 301;
procedure PostData(const Table: WideString; Value: OleVariant; var Ret: OleVariant); dispid 302;
function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; dispid 20000000;
function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
Options: Integer; const CommandText: WideString; var Params: OleVariant;
var OwnerData: OleVariant): OleVariant; dispid 20000001;
function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; dispid 20000002;
function AS_GetProviderNames: OleVariant; dispid 20000003;
function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; dispid 20000004;
function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
var OwnerData: OleVariant): OleVariant; dispid 20000005;
procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;
var Params: OleVariant; var OwnerData: OleVariant); dispid 20000006;
end;
// *********************************************************************//
// The Class CoTestService provides a Create and CreateRemote method to
// create instances of the default interface ITestService exposed by
// the CoClass TestService. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoTestService = class
class function Create: ITestService;
class function CreateRemote(const MachineName: string): ITestService;
end;
implementation
uses ComObj;
class function CoTestService.Create: ITestService;
begin
Result := CreateComObject(CLASS_TestService) as ITestService;
end;
class function CoTestService.CreateRemote(const MachineName: string): ITestService;
begin
Result := CreateRemoteComObject(MachineName, CLASS_TestService) as ITestService;
end;
end.

Unit2单元成功添加以下

前面新增了2个接口方法然后我们在这个单元里面实现方便客户端调用

代码如下

[delphi] view plain copy

unit Unit2;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,
DBClient, Project1_TLB, StdVcl, ADODB, Provider, DB;
type
TTestService = class(TRemoteDataModule, ITestService)
conData: TADOConnection;
dsTemp: TClientDataSet;
dspTemp: TDataSetProvider;
qryTemp: TADOQuery;
procedure RemoteDataModuleCreate(Sender: TObject);
private
I: Integer;
Params: OleVariant;
OwnerData: OleVariant;
// 自己加入
function InnerGetData(strSQL: String): OleVariant;
function InnerPostData(Delta: OleVariant): Integer;
protected
class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
procedure GetData(const Table, Where: WideString; var Ret: OleVariant);
safecall;
procedure PostData(const Table: WideString; Value: OleVariant;
var Ret: OleVariant); safecall;
public
{ Public declarations }
end;
implementation
{$R *.DFM}
procedure TTestService.GetData(const Table, Where: WideString;
var Ret: OleVariant);
const SQL = 'select * from %s where %s';
begin
Ret := Self.InnerGetData(Format(SQL, [Table, Where]));
end;
function TTestService.InnerGetData(strSQL: String): OleVariant;
begin
// 必须是CLOSE状态, 否则报错.
if qryTemp.Active then qryTemp.Active := False;
Result := Self.AS_GetRecords('dspTemp', -1, I, ResetOption+MetaDataOption,
strSQL, Params, OwnerData);
end;
function TTestService.InnerPostData(Delta: OleVariant): Integer;
begin
Self.AS_ApplyUpdates('dspTemp', Delta, 0, Result, OwnerData);
end;
procedure TTestService.PostData(const Table: WideString; Value: OleVariant;
var Ret: OleVariant);
var
KeyField: TField;
begin
dsTemp.Data := Value;
if dsTemp.IsEmpty then Exit;
{
这里假设每个表都有一个FKey字段, 并且值是唯一的.
也可以根据表中, 改成相应的主键字段名.
}
KeyField := dsTemp.FindField('FKey');
if KeyField=nil then raise Exception.Create(' 键值字段未发现.');
if KeyField.IsNull then
begin
qryTemp.SQL.Text := 'select * from '+Table+' where 1>2';
end
else
begin
qryTemp.SQL.Text := 'select * from '+Table+' where FKey='+QuotedStr(KeyField.AsString);
qryTemp.Open;
with qryTemp.FieldByName('FKey') do ProviderFlags := ProviderFlags + [pfInKey];
dspTemp.UpdateMode := upWhereKeyOnly;
end;
qryTemp.Open;
Ret := InnerPostData(Value);
end;
class procedure TTestService.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 TTestService.RemoteDataModuleCreate(Sender: TObject);
begin
Self.qryTemp.Connection := Self.conData;
Self.dspTemp.DataSet := Self.qryTemp;
Self.dspTemp.Options := Self.dspTemp.Options + [poAllowCommandText];
conData.ConnectionString:='File Name='+ExtractFilePath(ParamStr(0))+'conData.udl';
try
Self.conData.Open;
except
on e:Exception do
begin
end;
end;
end;
initialization
TComponentFactory.Create(ComServer, TTestService,
Class_TestService, ciMultiInstance, tmApartment);
end.

再讲讲conData.udl 文件的创建

新建一个txt文件

添加内容

[oledb]
; Everything after this line is an OLE DB initstring
Provider=SQLOLEDB.1;Password=test;Persist Security Info=True;User ID=sa;Initial Catalog=db_test;Data Source=192.168.0.1

保存修改扩展名为.udl 就可以了。

到此服务端写完了

开始写客户端程序之前( 先启动scktsrvr.exe 此在dephi程序的bin目录下 ) 然后启动服务端

如果不想在客户的机器上注册midas.dll 请在使用ClientDataSet单元中引用 MidasLib 单元

客户端开发:

新增TDCOMConnection（ComputerName选择服务器名称或者IP,ServerName选择服务端名称）、TClientDataSet连接DCOM