delphi三层DCOM架构

神龙之王 發表於 2019-11-11 10:17:00

DCOM架构:
服务端开发：
采用Delphi7+SQL2008
一、创建数据库和表
 
<div class="dp-highlighter bg_sql">
<div class="bar">
<div class="tools"> view plain copy
<div> </div>
</div>
</div>
<ol class="dp-sql" start="1">
<li class="alt">CREATE TABLE .(  </li>
<li>      NOT NULL,  </li>
<li class="alt">     [varchar](50) NULL,  </li>
<li>     [varchar](50) NULL,  </li>
<li class="alt">     [varchar](50) NULL,  </li>
<li>     [varchar](50) NULL,  </li>
<li class="alt">     [varchar](200) NULL  </li>
<li>) ON [PRIMARY]  </li>
</ol></div>
 二、写服务端
 
2.1 先创建一个application
<img src="//img-blog.csdn.net/20141024151212453?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center">
在窗体中添加Label如图显示
 
 
<div class="dp-highlighter bg_delphi">
<div class="bar">
<div class="tools"> view plain copy
<div> </div>

</div>

</div>
<ol class="dp-delphi" start="1">
<li class="alt">unit ufrmMain;  </li>
<li>  </li>
<li class="alt">interface  </li>
<li>  </li>
<li class="alt">uses  </li>
<li>  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  </li>
<li class="alt">  Dialogs, StdCtrls;  </li>
<li>  </li>
<li class="alt">type  </li>
<li>  TfrmMain = class(TForm)  </li>
<li class="alt">    lbl1: TLabel;  </li>
<li>  private  </li>
<li class="alt">    { Private declarations }  </li>
<li>  public  </li>
<li class="alt">    { Public declarations }  </li>
<li>  end;  </li>
<li class="alt">  </li>
<li>var  </li>
<li class="alt">  frmMain: TfrmMain;  </li>
<li>  </li>
<li class="alt">implementation  </li>
<li>  </li>
<li class="alt">{$R *.dfm}  </li>
<li>  </li>
<li class="alt">end.  </li>

</ol></div>
 2.2 File-New-Other 
<img src="//img-blog.csdn.net/20141024151252002?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center">
 
点击OK  在弹出的对话框中  填写
<img src="//img-blog.csdn.net/20141024151403981?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center">
名字自己根据需要填写
此时生成2个单元一个Project1_TLB 和 Unit2 单元
打开Project1_TLB 单元  按F12键
<img src="//img-blog.csdn.net/20141024151740228?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center">
在弹出的对话框中
 
Name就是我们要的方法名称（根据自己需要填写）GetData 获取数据
新增参数  如下图 
<img src="//img-blog.csdn.net/20141024151756905?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center"> 
 
再按相同的方法添加PostData方法（保存数据）
最终结果如下图
 
<img src="//img-blog.csdn.net/20141024151824735?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center">
添加后的最代码终结果
 
<div class="dp-highlighter bg_delphi">
<div class="bar">
<div class="tools"> view plain copy
<div> </div>

</div>

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

</ol></div>
 
 
 
Unit2单元成功添加以下
<img src="//img-blog.csdn.net/20141024151537203?watermark/2/text/aHR0cDovL2Jsb2cuY3Nkbi5uZXQvZ3lrdGho/font/5a6L5L2T/fontsize/400/fill/I0JBQkFCMA==/dissolve/70/gravity/Center">
前面新增了2个接口方法然后我们在这个单元里面  实现  方便客户端调用  
代码如下
 
<div class="dp-highlighter bg_delphi">
<div class="bar">
<div class="tools"> view plain copy
<div> </div>

</div>

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

</ol></div>
再讲讲conData.udl  文件的创建
 
新建一个txt文件   
添加内容
 ; 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 
来源：https://www.cnblogs.com/linjincheng/p/11833248.html

頁: [1]

琼殿技术论坛's Archiver

delphi三层DCOM架构