delphi三层DCOM架构

DCOM架构:

服务端开发：

采用Delphi7+SQL2008

一、创建数据库和表

1. CREATE TABLE [dbo].[tb_Department](
2. [FKey] [uniqueidentifier] NOT NULL,
3. [FName] [varchar](50) NULL,
4. [FAge] [varchar](50) NULL,
5. [FSex] [varchar](50) NULL,
6. [FMobile] [varchar](50) NULL,
7. [FRemark] [varchar](200) NULL
8. ) ON [PRIMARY]

二、写服务端

2.1 先创建一个application

在窗体中添加Label如图显示

1. unit ufrmMain;
2. interface
3. uses
4. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
5. Dialogs, StdCtrls;
6. type
7. TfrmMain = class(TForm)
8. lbl1: TLabel;
9. private
10. { Private declarations }
11. public
12. { Public declarations }
13. end;
14. var
15. frmMain: TfrmMain;
16. implementation
17. {$R *.dfm}
18. end.

2.2 File-New-Other

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

名字自己根据需要 填写

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

打开Project1_TLB 单元  按F12键

在弹出的对话框中

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

新增参数  如下图

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

最终结果如下图

添加后的最代码终结果

1. unit Project1_TLB;
2. // ************************************************************************ //
3. // WARNING
4. // -------
5. // The types declared in this file were generated from data read from a
6. // Type Library. If this type library is explicitly or indirectly (via
7. // another type library referring to this type library) re-imported, or the
8. // 'Refresh' command of the Type Library Editor activated while editing the
9. // Type Library, the contents of this file will be regenerated and all
10. // manual modifications will be lost.
11. // ************************************************************************ //
12. // PASTLWTR : 1.2
13. // File generated on 2014-10-24 14:24:49 from Type Library described below.
14. // ************************************************************************  //
15. // Type Lib: D:\Delphi7\Projects\Project1.tlb (1)
16. // LIBID: {C6713A20-F49B-4B06-8869-9E040C912074}
17. // LCID: 0
18. // Helpfile:
19. // HelpString: Project1 Library
20. // DepndLst:
21. //   (1) v2.0 stdole, (C:\Windows\SysWOW64\stdole2.tlb)
22. //   (2) v1.0 Midas, (C:\Windows\SysWOW64\midas.dll)
23. //   (3) v4.0 StdVCL, (C:\Windows\SysWOW64\stdvcl40.dll)
24. // ************************************************************************ //
25. {$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
26. {$WARN SYMBOL_PLATFORM OFF}
27. {$WRITEABLECONST ON}
28. {$VARPROPSETTER ON}
29. interface
30. uses Windows, ActiveX, Classes, Graphics, Midas, StdVCL, Variants;
31. // *********************************************************************//
32. // GUIDS declared in the TypeLibrary. Following prefixes are used:
33. //   Type Libraries     : LIBID_xxxx
34. //   CoClasses          : CLASS_xxxx
35. //   DISPInterfaces     : DIID_xxxx
36. //   Non-DISP interfaces: IID_xxxx
37. // *********************************************************************//
38. const
39. // TypeLibrary Major and minor versions
40. Project1MajorVersion = 1;
41. Project1MinorVersion = 0;
42. LIBID_Project1: TGUID = '{C6713A20-F49B-4B06-8869-9E040C912074}';
43. IID_ITestService: TGUID = '{C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}';
44. CLASS_TestService: TGUID = '{82AEC5B8-E53F-4725-A24D-456FD570E355}';
45. type
46. // *********************************************************************//
47. // Forward declaration of types defined in TypeLibrary
48. // *********************************************************************//
49. ITestService = interface;
50. ITestServiceDisp = dispinterface;
51. // *********************************************************************//
52. // Declaration of CoClasses defined in Type Library
53. // (NOTE: Here we map each CoClass to its Default Interface)
54. // *********************************************************************//
55. TestService = ITestService;
56. // *********************************************************************//
57. // Interface: ITestService
58. // Flags:     (4416) Dual OleAutomation Dispatchable
59. // GUID:      {C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}
60. // *********************************************************************//
61. ITestService = interface(IAppServer)
62. ['{C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}']
63. procedure GetData(const Table: WideString; const Where: WideString; var Ret: OleVariant); safecall;
64. procedure PostData(const Table: WideString; Value: OleVariant; var Ret: OleVariant); safecall;
65. end;
66. // *********************************************************************//
67. // DispIntf:  ITestServiceDisp
68. // Flags:     (4416) Dual OleAutomation Dispatchable
69. // GUID:      {C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}
70. // *********************************************************************//
71. ITestServiceDisp = dispinterface
72. ['{C59D7F3C-4AE7-473B-81B8-8EE1C73BB2B1}']
73. procedure GetData(const Table: WideString; const Where: WideString; var Ret: OleVariant); dispid 301;
74. procedure PostData(const Table: WideString; Value: OleVariant; var Ret: OleVariant); dispid 302;
75. function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer;
76. out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; dispid 20000000;
77. function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
78. Options: Integer; const CommandText: WideString; var Params: OleVariant;
79. var OwnerData: OleVariant): OleVariant; dispid 20000001;
80. function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; dispid 20000002;
81. function AS_GetProviderNames: OleVariant; dispid 20000003;
82. function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; dispid 20000004;
83. function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
84. var OwnerData: OleVariant): OleVariant; dispid 20000005;
85. procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;
86. var Params: OleVariant; var OwnerData: OleVariant); dispid 20000006;
87. end;
88. // *********************************************************************//
89. // The Class CoTestService provides a Create and CreateRemote method to
90. // create instances of the default interface ITestService exposed by
91. // the CoClass TestService. The functions are intended to be used by
92. // clients wishing to automate the CoClass objects exposed by the
93. // server of this typelibrary.
94. // *********************************************************************//
95. CoTestService = class
96. class function Create: ITestService;
97. class function CreateRemote(const MachineName: string): ITestService;
98. end;
99. implementation
100. uses ComObj;
101. class function CoTestService.Create: ITestService;
102. begin
103. Result := CreateComObject(CLASS_TestService) as ITestService;
104. end;
105. class function CoTestService.CreateRemote(const MachineName: string): ITestService;
106. begin
107. Result := CreateRemoteComObject(MachineName, CLASS_TestService) as ITestService;
108. end;
109. end.

Unit2单元成功 添加以下

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

代码如下

1. unit Unit2;
2. {$WARN SYMBOL_PLATFORM OFF}
3. interface
4. uses
5. Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,
6. DBClient, Project1_TLB, StdVcl, ADODB, Provider, DB;
7. type
8. TTestService = class(TRemoteDataModule, ITestService)
9. conData: TADOConnection;
10. dsTemp: TClientDataSet;
11. dspTemp: TDataSetProvider;
12. qryTemp: TADOQuery;
13. procedure RemoteDataModuleCreate(Sender: TObject);
14. private
15. I: Integer;
16. Params: OleVariant;
17. OwnerData: OleVariant;
18. // 自己加入
19. function InnerGetData(strSQL: String): OleVariant;
20. function InnerPostData(Delta: OleVariant): Integer;
21. protected
22. class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
23. procedure GetData(const Table, Where: WideString; var Ret: OleVariant);
24. safecall;
25. procedure PostData(const Table: WideString; Value: OleVariant;
26. var Ret: OleVariant); safecall;
27. public
28. { Public declarations }
29. end;
30. implementation
31. {$R *.DFM}
32. procedure TTestService.GetData(const Table, Where: WideString;
33. var Ret: OleVariant);
34. const SQL = 'select * from %s where %s';
35. begin
36. Ret := Self.InnerGetData(Format(SQL, [Table, Where]));
37. end;
38. function TTestService.InnerGetData(strSQL: String): OleVariant;
39. begin
40. // 必须是CLOSE状态, 否则报错.
41. if qryTemp.Active then qryTemp.Active := False;
42. Result := Self.AS_GetRecords('dspTemp', -1, I, ResetOption+MetaDataOption,
43. strSQL, Params, OwnerData);
44. end;
45. function TTestService.InnerPostData(Delta: OleVariant): Integer;
46. begin
47. Self.AS_ApplyUpdates('dspTemp', Delta, 0, Result, OwnerData);
48. end;
49. procedure TTestService.PostData(const Table: WideString; Value: OleVariant;
50. var Ret: OleVariant);
51. var
52. KeyField: TField;
53. begin
54. dsTemp.Data := Value;
55. if dsTemp.IsEmpty then Exit;
56. {
57. 这里假设每个表都有一个FKey字段, 并且值是唯一的.
58. 也可以根据表中, 改成相应的主键字段名.
59. }
60. KeyField := dsTemp.FindField('FKey');
61. if KeyField=nil then raise Exception.Create(' 键值字段未发现.');
62. if KeyField.IsNull then
63. begin
64. qryTemp.SQL.Text := 'select * from '+Table+' where 1>2';
65. end
66. else
67. begin
68. qryTemp.SQL.Text := 'select * from '+Table+' where FKey='+QuotedStr(KeyField.AsString);
69. qryTemp.Open;
70. with qryTemp.FieldByName('FKey') do ProviderFlags := ProviderFlags + [pfInKey];
71. dspTemp.UpdateMode := upWhereKeyOnly;
72. end;
73. qryTemp.Open;
74. Ret := InnerPostData(Value);
75. end;
76. class procedure TTestService.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
77. begin
78. if Register then
79. begin
80. inherited UpdateRegistry(Register, ClassID, ProgID);
81. EnableSocketTransport(ClassID);
82. EnableWebTransport(ClassID);
83. end else
84. begin
85. DisableSocketTransport(ClassID);
86. DisableWebTransport(ClassID);
87. inherited UpdateRegistry(Register, ClassID, ProgID);
88. end;
89. end;
90. procedure TTestService.RemoteDataModuleCreate(Sender: TObject);
91. begin
92. Self.qryTemp.Connection := Self.conData;
93. Self.dspTemp.DataSet := Self.qryTemp;
94. Self.dspTemp.Options := Self.dspTemp.Options + [poAllowCommandText];
95. conData.ConnectionString:='File Name='+ExtractFilePath(ParamStr(0))+'conData.udl';
96. try
97. Self.conData.Open;
98. except
99. on e:Exception do
100. begin
101. end;
102. end;
103. end;
104. initialization
105. TComponentFactory.Create(ComServer, TTestService,
106. Class_TestService, ciMultiInstance, tmApartment);
107. 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