delphi三层DCOM架构

DCOM架构:

服务端开发：

采用Delphi7+SQL2008

一、创建数据库和表

 

[sql] view plain copy
 
  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如图显示

 

 

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


2.2 File-New-Other 

 

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

名字自己根据需要 填写

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

打开Project1_TLB 单元  按F12键

在弹出的对话框中

 

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

新增参数  如下图 

 

 

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

最终结果如下图

 

添加后的最代码终结果

 

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



 

 

Unit2单元成功 添加以下

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

代码如下

 

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

posted on 2019-11-11 10:17  岁月寒风  阅读(1168)  评论(0)  编辑  收藏  举报

导航