Delphi 三層框架開發 服務端開發
阿新 • • 發佈：2019-01-27
採用Delphi7+SQL2008
一、建立資料庫和表
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如圖顯示
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方法（儲存資料）
最終結果如下圖
新增後的最程式碼終結果
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個介面方法 然後我們在這個單元裡面 實現 方便客戶端呼叫
程式碼如下
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.
新建一個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 單元
專案原始碼下載 —— http://download.csdn.net/detail/gykthh/8077801