这是maozefa(之源)的代码,对我帮助很大,希望对你也有所启发,
如果maozefa(之源)在的话,请以后多多关照//服务器主模块单元
unit ServerMain;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ImgList, Db, DBTables, ComCtrls, StdCtrls, ExtCtrls, ADODB, Menus;const
// 服务器在注册表的登记项路径,程序安装时自动登记
RegPath = '\SoftWare\Zfinfo\ZfServer';
UpdatePath = '\Software\UpdateData';
ConnectionStr = 'Provider=SQLOLEDB.1;Password=195316;Persist Security Info=True;User ID=sa;Initial Catalog=Zfinfo';
// ConnectionStr = 'Provider=MSDASQL.1;Password=195316;Persist Security Info=True;User ID=sa;Data Source=ZfInfoDB;Initial Catalog=ZfInfo';
type
TServerMainForm = class(TForm)
Image1: TImage;
ListView1: TlistView;
Label1: TLabel;
ImageList1: TImageList;
ADOConnection: TADOConnection;
ADOQuery: TADOQuery;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure N2Click(Sender: TObject);
private
{ Private declarations }
FRecNumber: Integer;
FSendDate: TDate;
FSystemPath: String;
FUpdateFlag: Integer;
function GetRecNumber: Integer;
procedure SetSendDate(aDate: TDate);
procedure ClearClients;
public
{ Public declarations }
procedure RegUpdateFlag(Flag: Integer);
function InsertClient: TListItem;
// SendDate,RecNumber属性为远程数据模块自动填充信息记录
// 主键(记录发送时间和编号)用
property RecNumber: Integer read GetRecNumber;
property SendDate: TDate read FSendDate write SetSendDate;
// 系统路径
property SystemPath: String read FSystemPath;
// 二进制文件存取路径
property UpdateFlag: Integer read FUpdateFlag;
end;var
ServerMainForm: TServerMainForm;implementationuses Registry, ServerRes;{$R *.DFM}{ TServerMainForm }
// 主Form建立事件
procedure TServerMainForm.FormCreate(Sender: TObject);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create; // 建立注册表对象,默认Root:KKEY_CURRENT_USER
try
if Reg.OpenKey(RegPath, False) then // 如果登记路径存在,读系统路径
FSystemPath := Reg.ReadString('SystemPath')
else Halt; // 否则程序退出(非正常安装程序)
if Reg.OpenKey(UpdatePath, False) then
FUpdateFlag := Reg.ReadInteger('UpdateFlag')
else FUpdateFlag := 0;
finally
Reg.Free; // 释放注册表对象
end;
if SystemPath[Length(SystemPath)] <> '\' then
FSystemPath := SystemPath + '\';
ADOConnection.ConnectionString := ConnectionStr;
ADOConnection.Connected := True;
if not ADOConnection.Connected then
ShowMessage('连接数据库失败!');
SendDate := Date;
end;
// 从列表中清除所有已经完成任务的的客户记载
procedure TServerMainForm.ClearClients;
var
I: Integer;
begin
I := 0;
while I < ListView1.Items.Count do
if ListView1.Items.Item[I].ImageIndex = 1 then Inc(I)
else ListView1.Items.Delete(I);
end;
// RecNumber属性(信息记录编号)的Get方法
function TServerMainForm.GetRecNumber: Integer;
begin
Inc(FRecNumber); // 现有记录编号+1,并返回
Result := FRecNumber;
end;
// 在客户列表中插入一个客户记载(列表项),返回列表项
function TServerMainForm.InsertClient: TListItem;
begin
if SendDate <> Date then // 如果信息记录时间<>当前时间
begin
SendDate := Date; // 设置信息记录时间=当前时间,取当日最大的记录编号
ClearClients; // 从列表中清除所有已经完成任务的的客户记载
end;
Result := ListView1.Items.Insert(0);
Result.ImageIndex := 1;
end;
// SendDate属性(信息记录时间)的Put方法
procedure TServerMainForm.SetSendDate(aDate: TDate);
begin
FSendDate := aDate;
ADOQuery.Parameters[0].Value := aDate;
ADOQuery.Active := True;
FRecNumber := ADOQuery.Fields[0].AsInteger;
ADOQuery.Active := False;
end;procedure TServerMainForm.RegUpdateFlag(Flag: Integer);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
if Reg.OpenKey(UpdatePath, True) then
Reg.WriteInteger('UpdateFlag', Flag);
finally
Reg.Free;
FUpdateFlag := Flag;
end;
end;procedure TServerMainForm.N1Click(Sender: TObject);
begin
ResultForm.Show;
end;procedure TServerMainForm.N2Click(Sender: TObject);
begin
Close;
end;end.
如果maozefa(之源)在的话,请以后多多关照//服务器主模块单元
unit ServerMain;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ImgList, Db, DBTables, ComCtrls, StdCtrls, ExtCtrls, ADODB, Menus;const
// 服务器在注册表的登记项路径,程序安装时自动登记
RegPath = '\SoftWare\Zfinfo\ZfServer';
UpdatePath = '\Software\UpdateData';
ConnectionStr = 'Provider=SQLOLEDB.1;Password=195316;Persist Security Info=True;User ID=sa;Initial Catalog=Zfinfo';
// ConnectionStr = 'Provider=MSDASQL.1;Password=195316;Persist Security Info=True;User ID=sa;Data Source=ZfInfoDB;Initial Catalog=ZfInfo';
type
TServerMainForm = class(TForm)
Image1: TImage;
ListView1: TlistView;
Label1: TLabel;
ImageList1: TImageList;
ADOConnection: TADOConnection;
ADOQuery: TADOQuery;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure N2Click(Sender: TObject);
private
{ Private declarations }
FRecNumber: Integer;
FSendDate: TDate;
FSystemPath: String;
FUpdateFlag: Integer;
function GetRecNumber: Integer;
procedure SetSendDate(aDate: TDate);
procedure ClearClients;
public
{ Public declarations }
procedure RegUpdateFlag(Flag: Integer);
function InsertClient: TListItem;
// SendDate,RecNumber属性为远程数据模块自动填充信息记录
// 主键(记录发送时间和编号)用
property RecNumber: Integer read GetRecNumber;
property SendDate: TDate read FSendDate write SetSendDate;
// 系统路径
property SystemPath: String read FSystemPath;
// 二进制文件存取路径
property UpdateFlag: Integer read FUpdateFlag;
end;var
ServerMainForm: TServerMainForm;implementationuses Registry, ServerRes;{$R *.DFM}{ TServerMainForm }
// 主Form建立事件
procedure TServerMainForm.FormCreate(Sender: TObject);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create; // 建立注册表对象,默认Root:KKEY_CURRENT_USER
try
if Reg.OpenKey(RegPath, False) then // 如果登记路径存在,读系统路径
FSystemPath := Reg.ReadString('SystemPath')
else Halt; // 否则程序退出(非正常安装程序)
if Reg.OpenKey(UpdatePath, False) then
FUpdateFlag := Reg.ReadInteger('UpdateFlag')
else FUpdateFlag := 0;
finally
Reg.Free; // 释放注册表对象
end;
if SystemPath[Length(SystemPath)] <> '\' then
FSystemPath := SystemPath + '\';
ADOConnection.ConnectionString := ConnectionStr;
ADOConnection.Connected := True;
if not ADOConnection.Connected then
ShowMessage('连接数据库失败!');
SendDate := Date;
end;
// 从列表中清除所有已经完成任务的的客户记载
procedure TServerMainForm.ClearClients;
var
I: Integer;
begin
I := 0;
while I < ListView1.Items.Count do
if ListView1.Items.Item[I].ImageIndex = 1 then Inc(I)
else ListView1.Items.Delete(I);
end;
// RecNumber属性(信息记录编号)的Get方法
function TServerMainForm.GetRecNumber: Integer;
begin
Inc(FRecNumber); // 现有记录编号+1,并返回
Result := FRecNumber;
end;
// 在客户列表中插入一个客户记载(列表项),返回列表项
function TServerMainForm.InsertClient: TListItem;
begin
if SendDate <> Date then // 如果信息记录时间<>当前时间
begin
SendDate := Date; // 设置信息记录时间=当前时间,取当日最大的记录编号
ClearClients; // 从列表中清除所有已经完成任务的的客户记载
end;
Result := ListView1.Items.Insert(0);
Result.ImageIndex := 1;
end;
// SendDate属性(信息记录时间)的Put方法
procedure TServerMainForm.SetSendDate(aDate: TDate);
begin
FSendDate := aDate;
ADOQuery.Parameters[0].Value := aDate;
ADOQuery.Active := True;
FRecNumber := ADOQuery.Fields[0].AsInteger;
ADOQuery.Active := False;
end;procedure TServerMainForm.RegUpdateFlag(Flag: Integer);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
if Reg.OpenKey(UpdatePath, True) then
Reg.WriteInteger('UpdateFlag', Flag);
finally
Reg.Free;
FUpdateFlag := Flag;
end;
end;procedure TServerMainForm.N1Click(Sender: TObject);
begin
ResultForm.Show;
end;procedure TServerMainForm.N2Click(Sender: TObject);
begin
Close;
end;end.
解决方案 »
- 有人知道 adoquery 的params 里面的 bolb 类型参数 如何转换成 提交 mssql 数据库的字符串值么 ?
- 如何得到指定database中所有的数据库名?
- 求助 acm
- 在线等待 30分--大虾帮忙看看怎么办(1.怎么把*.bmp转化为*.ico。 2.怎么让动态生成的RzShellTree1有click事件)
- 谁能讲一下什么是VCL,是不是很简单?
- 用TWebBrowser时如何禁止POP网页弹出?
- 请问有否这样的一个控件?
- 急!!! MSComm中output的输出类型问题(输出字符要求转化为hex 16进制) : delphi中如何声明16进制数 ?
- 看我的代码,是不是很累,很无聊。
- 请问关于TRegistry的详细介绍。。。小弟E文太差。。谢谢(63分)
- 有没有好的组合查询控件呀!
- 谁能给COM一个准确的定义
// 服务器远程数据模块单元
unit ServerData;interfaceuses
Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,
DBClient, ZfServer_TLB, StdVcl, Provider, Db, DBTables, ComCtrls, ADODB;type
TZfInfoServer = class(TRemoteDataModule, IZfInfoServer)
ClassProvider: TDataSetProvider;
TypeProvider: TDataSetProvider;
UsersProvider: TDataSetProvider;
ItemsProvider: TDataSetProvider;
ItemsProvider1: TDataSetProvider;
NewProvider: TDataSetProvider;
RecProvider: TDataSetProvider;
ClassQuery: TADOQuery;
TypeQuery: TADOQuery;
UsersQuery: TADOQuery;
ItemsQuery: TADOQuery;
ItemsQuery1: TADOQuery;
NewQuery: TADOQuery;
RecQuery: TADOQuery;
procedure RemoteDataModuleDestroy(Sender: TObject);
procedure ItemsQueryAfterOpen(DataSet: TDataSet);
procedure NewProviderBeforeUpdateRecord(Sender: TObject;
SourceDS: TDataSet; DeltaDS: TClientDataSet; UpdateKind: TUpdateKind;
var Applied: Boolean);
private
{ Private declarations }
FItem: TListItem;
protected
class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
procedure SetClientInfo(const UserName, WorkInfo: WideString); safecall;
procedure SetUpdateFlag(Flag: Integer); safecall;
public
{ Public declarations }
end;implementationuses ServerMain;{$R *.DFM}class procedure TZfInfoServer.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 TZfInfoServer.RemoteDataModuleDestroy(Sender: TObject);
begin
if Tag <> 0 then FItem.ImageIndex := 0;
end;
// 信息记录表Items已打开事件
procedure TZfInfoServer.ItemsQueryAfterOpen(DataSet: TDataSet);
var
Code: String;
InfoDate: TDateTime;
begin
if Tag = 0 then Exit;
with TADOQuery(DataSet) do // 日记表中插入一条接收信息的记录
begin
Code := Parameters[2].Value; // 在ItemsQuery参数表中取用户代码和信息时间
InfoDate := Parameters[0].Value;
end;
with RecQuery do // 设置RecQuery的SQL语句并执行
begin
// SQL插入语句中的字串和日期串必须用引号(单双均可),只能用ExecSQL不能用Open
Code := '(' + #39 + Code + #39 + ',' + #39 + FormatDateTime('mm/dd/yyyy hh:mm:ss', Now) +
#39 + ',' + #39 + FormatDateTime('mm/dd/yyyy', InfoDate) + #39 + ')';
SQL.Add('Insert Into QueryRec Values' + Code);
ExecSQL;
end;
end;
// NewQuery接口NewProvider的数据更新事件
procedure TZfInfoServer.NewProviderBeforeUpdateRecord(Sender: TObject;
SourceDS: TDataSet; DeltaDS: TClientDataSet; UpdateKind: TUpdateKind;
var Applied: Boolean);
begin
// 如果客户程序插入信息记录同时未设定主键,
// 从主窗口获取唯一的记录主键(发送时间和当日记录序号)
if (UpdateKind = ukInsert) and (DeltaDS.FieldByName('NUM').Asinteger <= 0)
and (ServerMainForm.UpdateFlag = 0) then
begin
DeltaDS.Edit;
DeltaDS.FieldByName('NUM').AsInteger := ServerMainForm.RecNumber;
DeltaDS.FieldByName('SENDDATE').AsDateTime := ServerMainForm.SendDate;
end;
end;
// 以下是在类型库中自定义的客户接口过程,这些过程可由不同语言客户程序使用多种接口访问。
// Delphi中客户一般使用连接元件的AppServer访问// 设置用户操作信息,参数:用户名,操作信息
procedure TZfInfoServer.SetClientInfo(const UserName, WorkInfo: WideString);
begin
Tag := 1; // 使用Tag属性作标记,1表示已插入客户访问列表项
FItem := ServerMainForm.InsertClient; // 插入并返回一个客户列表项
FItem.Caption := UserName; // 项标题=用户名
FItem.SubItems.Add(WorkInfo); // 增加一个子项描述操作信息
end;procedure TZfInfoServer.SetUpdateFlag(Flag: Integer);
begin
ServerMainForm.RegUpdateFlag(Flag);
end;initialization
TComponentFactory.Create(ComServer, TZfInfoServer,
Class_ZfInfoServer, ciMultiInstance, tmApartment);
end.// 一个利用聊天元件制作的用户快速回复反馈单元
unit ServerRes;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, Buttons, ScktComp, ExtCtrls, ComCtrls;type
TResultForm = class(TForm)
Bevel1: TBevel;
Panel1: TPanel;
Memo1: TMemo;
SpeedButton1: TSpeedButton;
ServerSocket: TServerSocket;
SpeedButton2: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source,
HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
procedure ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure SpeedButton1Click(Sender: TObject);
procedure SpeedButton2Click(Sender: TObject);
protected
end;var
ResultForm: TResultForm;implementation{$R *.DFM}procedure TResultForm.FormCreate(Sender: TObject);
begin
ServerSocket.Active := True;
end;procedure TResultForm.ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source, HelpFile: string;
HelpContext: Integer; var CancelDisplay: Wordbool);
begin
ShowMessage(Description);
end;procedure TResultForm.ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
if not Visible then Show;
Memo1.Lines.Add(ForMatDateTime('(yyyy/mm/dd tt)', Now) + Socket.ReceiveText);
end;procedure TResultForm.SpeedButton1Click(Sender: TObject);
begin
Close;
end;procedure TResultForm.SpeedButton2Click(Sender: TObject);
begin
Memo1.Lines.Clear;
end;end.
还有吗?但我不想看李维的东东