困扰我一年的问题,希望2007年能有高人解决? ( 积分: 100 )

我做一聊天系统
我定义如下结构体
TP2PMessage = packed record //P2P之间聊天数据包
name: array [0..20] of char;
Text: array [0..1000] of char;
Sendmsg : array of byte;
end;

问题如下:
如果我只传文字信息,即将Sendmsg : array of byte 改为Sendmsg :array [0..1000] of char;程序一切正常
如果我传输信息中包含文字和图片,我将Sendmsg 定义为array of byte ,小弟不知该如何处理,发送信息的编辑框我用的是RichviewEdit,我的思路是在发送端将Richviewedit的内容转为Stream,再将Stream转为array of byte 后发送到接收端,在接收端将array of byte 转为Stream, 然后再载入到Richview.
这中间的过程不知该如何处理,请求各位富翁伸手相助,能有实际代码最好,小弟将再加分以示感谢!!!

有做过聊天系统的一定遇到过此问题,请做过聊天系统的富翁伸手相助!!!

看看我的定义
TDlgMessage = (dmNone, dmLogin, dmOnLine, dmOffLine, dmRefresh, dmMessage,
dmDocInfo, dmFileTrans, dmReadFromSvr, dmBroadcast);

TDocInformation = Record
Table : string[10];
RecID : integer;
end;

TBaseInfo = Record
Date : TDateTime;
user : string[8];
ip : string[15];
msg : string[50];
dlg : TDlgMessage;
end;

不能在结构中包含流，因为流的size 是不定的，

Sendmsg : array of byte; 定义没有任何作用，没有定义Szie，所有的内容就用流实现就行了。 用SendBuffer

procedure Tdm.UdpServerUDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
begin
Read(AData);
end;

procedure Tdm.Read(AData: TStream);
var
Info: TBaseInfo;
DocInfo: TDocInformation;
Files: array[0..1024] of char;
begin
fillChar(info, sizeof(info), 0);
AData.Position:=0;
AData.ReadBuffer(info, sizeof(info));
case info.dlg of
dmLogin:
begin
UdpClient.Host:=info.ip;
sendPkInfo(dmOnLine);
if userIndex(info.user)<>-1 then
userList[userIndex(info.user)]:=info.user+'^'+info.ip;
UserLogChange(info.user, true);
end;
dmOnLine:
begin
if userIndex(info.user)<>-1 then
userList[userIndex(info.user)]:=info.user+'^'+info.ip;
UserLogChange(info.user, true);
end;

dmOffLine:
if userList<>nil then
begin
if userIndex(info.user)<>-1 then
userList[userIndex(info.user)]:=info.user;
UserLogChange(info.user, false);
end;

dmRefresh:
begin

end;
//
dmMessage:
begin
ReceiveMsg(info, AData);
end;

dmDocInfo:
begin
Adata.Position:=sizeof(info);
Adata.ReadBuffer(DocInfo, sizeof(Docinfo));
TfmNotify.ShowDocInfo(info, DocInfo);
end;

dmBroadcast:
begin
Broadcast(AData);
end;

dmFileTrans:
if findWindow('TfmReceiveFile', nil)=0 then
begin
AData.Position:=sizeof(info);
Adata.Read(Files, Adata.Size-sizeof(info));
TfmReceiveFile.CreateExe(info.user, info.ip, Files, info.msg);
end;

dmReadFromSvr: ReadMsgFromSever;

end;
end;

OK :
http://blog.163.com/gongyuzhuo

拷贝你的结构在下面：
TP2PMessage = packed record
name: array [0..20] of char;
Text: array [0..1000] of char;
Sendmsg : array of byte;
end;

这个结构中的 Sendmsg 条目与语言相关，如果这个结构 *仅仅* 用在 Delphi 语言写的程序中，大概有很大的机会可以成功传递，但是否真正成功，也是和程序编写的上下文相关的。

用于 P2P 传输，需要明确一个结构占用的大小，Sendmsg 的定义方式显然不能从结构本身得出实际占用的大小。也就是说，你需要把 Sendmsg 重新定义成一种显而易见的大小表示，或者，你可以增加一条记录来指明 Sendmsg 实际占用的大小，最后在发送时把整个结构中的全部数据都传出去，并在接收端收取全部数据。

PW：按原来的 Sendmsg 定义，从上可知，传送时仅传递了 Sendmsg 数据的指针，真正的数据没有被传送，而是留在了发送端的电脑内存里了。

Sendmsg,定义不允许是动态数组吧？

呵呵，开个玩笑：如果累计使用Delphi写程序小于1500小时的话，楼上的回答就算是正确的，如果大于了1500小时，楼上这个回答就基本算是错误的了。

谢谢xuxiaohan、sundata和小雨哥的回答。
to:xuxiaohan
你的方法我已实现，只传文字，我现在需要的是传的信息是即有图片，又有文字，像QQ一样。
to:sundata
如果不允许用动态数组，我改为array[0..1024] of byte可以吧，还是我的问题，该如何处理。
to:小雨哥
按你的方法，我将数据包的结构改变如下
TP2PMessage = packed record //P2P之间聊天数据包
name: array [0..20] of char;
Text: array [0..1000] of char;
size: integer; Sendmsg的大小
Sendmsg : array of byte;
end;
我的问题还是发送和接收端对Sendmsg如何处理
我的信息的编辑框是Richviewedit
期待大侠出手相助！！！

主要是在发送时把由 Sendmsg 指出的、数据尺寸为 size 的数据全部压入发送栈，连同这个结构的其他内容一起发送。如果你只是把这个结构直接发送，意味着 Sendmsg 仅发出了一个指针，别的接收到数据的机器永远没有可能仅凭一个 Sendmsg 指针而跨越机器，到你的机器内存里来读数据的。

谢小雨哥给我的启发,我试一试.

我的就是 QQ 一样，还可以有 动态表情， 用RichView 或者 RxRichedit 实现。

我的意思是，在结构里面根本不需要定义 Sendmsg : array of byte;
没有这个必要，也不切实际，因为发送的内容（Richedit的内容）是不定长度的，
发送的时候，将结构加到 包 的头部就可以啦。

接收的时候，从包 的 结构后面 读出 流就可以啦。

谢谢xuxiaohan,你是我的救星
能否将你的结构定义及发送和接收的例程传给我,我再给你另加200分.
我知道200分对你来说不处什么,可我急切需要这方面的例程,请你帮帮我.
我的邮箱:jianbo-zhang@163.com

xuxiaohan的方法比较好，俺是明白了，楼主那？

[]

这个是聊天的编辑器， RxRichedit 做的， 可以插入动态表情；
unit RicEditmsgBox;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ComCtrls, BaseForm, Buttons, slUser,
srToolButton, ImgList, GifImage, ExtDlgs, Menus, commx, RxRichEd;

type

TslUser = class(TFrSlUser)
public
procedure loadTv; override;
end;

TfmRicheditMsgBox = class(TfmBase)
Panel2: TPanel;
pnMuser: TPanel;
Panel5: TPanel;
Panel6: TPanel;
btClose: TsrToolButton;
btReply: TsrToolButton;
toolbar: TPanel;
spb: TsrToolButton;
tbPicture: TsrToolButton;
tbFont: TsrToolButton;
tbFace: TsrToolButton;
FontDialog1: TFontDialog;
opdialog: TOpenPictureDialog;
mpop: TPopupMenu;
miCopy: TMenuItem;
miPaste: TMenuItem;
miFont: TMenuItem;
miCut: TMenuItem;
N6: TMenuItem;
miSelectAll: TMenuItem;
hsPopMenu: TPopupMenu;
hsSelectAll: TMenuItem;
hsCopy: TMenuItem;
MenuItem5: TMenuItem;
hsSavePicAs: TMenuItem;
hsAddFace: TMenuItem;
Panel1: TPanel;
Panel3: TPanel;
spd: TSavePictureDialog;
srToolButton1: TsrToolButton;
Timer2: TTimer;
edHistory: TRxRichEdit;
Splitter1: TSplitter;
Editor: TRxRichEdit;
Panel4: TPanel;
reBuffer: TRxRichEdit;
cName: TsrToolButton;
procedure btCloseClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btReplyClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure hisListMeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure spbClick(Sender: TObject);
procedure tbFontClick(Sender: TObject);
procedure tbFaceClick(Sender: TObject);
procedure tbPictureClick(Sender: TObject);
procedure mi(Sender: TObject; ACanvas: TCanvas; var Width,
Height: Integer);
procedure adDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
State: TOwnerDrawState);
procedure miCutClick(Sender: TObject);
procedure miCopyClick(Sender: TObject);
procedure miPasteClick(Sender: TObject);
procedure miFontClick(Sender: TObject);
procedure miSelectAllClick(Sender: TObject);
procedure wmClose(var msg: TMessage); message WM_CLOSE;
procedure rvHsEditorContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
procedure hsSelectAllClick(Sender: TObject);
procedure hsSavePicAsClick(Sender: TObject);
procedure srToolButton1Click(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure EditorKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
procedure EditorChange(Sender: TObject);
procedure cNameClick(Sender: TObject);
private
{ Private declarations }
FshowHistory: boolean;
FMuser: boolean;
FslUser: TslUser;
FFace: TpopFace;
FhaveNewMsg: boolean;
Stream: TMemoryStream;
AName: string;
procedure createTv;
procedure setMultuser(const Value: boolean);
procedure onSelectFace(Sender: TObject);
procedure InsertPicture(FName: string);
procedure sendRvMsg;
procedure SendRVMsgMult(users: TStrings);
procedure Addhs;
procedure cmReceiveMsg(var message: Tmessage); message CM_RECEIVEMSG;
procedure WmWndPosChange(var Msg: TWMWINDOWPOSCHANGING); message WM_WINDOWPOSCHANGING;
function CurrText: TRxTextAttributes;
// procedure paste;
procedure goBottom;
procedure editCombine(edTarget, edSource: TRxRichedit);
protected
procedure createParams(var params: TCreateParams); override;
public
{ Public declarations }
TalkWith: string;
TalkWithIP: string;
procedure AddMessage(From: string; AStream: TStream);
class function ExistMsgBox(Ip: string): TfmRicheditMsgBox;
property showMultUser: boolean read FMuser write setMultuser;
end;

var
fmRicheditMsgBox: TfmRicheditMsgBox;

implementation

uses frmMain, dmMain, DB, ADODB, myfunctions, math, checkTV,
splash, SendFileExe;

{$R *.dfm}

function isSizeToobig(size: integer): boolean;
begin
result:=size>22708;
end;

procedure TfmRicheditMsgBox.btCloseClick(Sender: TObject);
begin
visible:=false;
end;

procedure TfmRicheditMsgBox.FormClose(Sender: TObject; var Action: TCloseAction);
begin
action:=caFree;
end;

procedure TfmRicheditMsgBox.btReplyClick(Sender: TObject);
begin
lockWindowUpdate(editor.Handle);
try
Addhs;
Timer2.Enabled:=false;
FhaveNewMsg:=false;
if showMultUser and (Fsluser.selectUsers.Count>1) then
SendRVMsgMult(Fsluser.selectUsers)
else
sendRvMsg;
editor.Clear;
finally
lockWindowUpdate(0);
end;
end;

procedure TfmRicheditMsgBox.FormCreate(Sender: TObject);
begin
inherited;
AName:='';
if not DirectoryExists(DEF_DIR+'/Face') then
with TfmSplash.create(nil) do
begin
downLoadFace;
Free;
end;
FFace:=TpopFace.create(toolbar, DEF_DIR+'/Face/*.gif');
FFace.onSelectImage:=onSelectFace;
Stream:=TMemoryStream.Create;
end;

procedure TfmRicheditMsgBox.Button1Click(Sender: TObject);
begin
//showHistory:=not showHistory;
end;

procedure TfmRicheditMsgBox.hisListMeasureItem(Control: TWinControl;
Index: Integer; var Height: Integer);
begin
Height:=2*height + 8;
end;

procedure TfmRicheditMsgBox.createParams(var params: TCreateParams);
begin
inherited createParams(params);
params.ExStyle:=params.ExStyle or WS_EX_APPWINDOW;
end;

procedure TfmRicheditMsgBox.setMultuser(const Value: boolean);
begin
lockWindowUpdate(handle);
try
FMuser := Value;
if value then
begin
if WindowState = wsNormal then width:=Width+pnMuser.Width;
if not assigned(Fsluser) then createTV;
spb.ImageIndex:=48
end
else
begin
if WindowState = wsNormal then width:=Width-pnMuser.Width;
spb.ImageIndex:=47;
end;
pnMuser.Visible:=value;
finally
LockWindowUpdate(0);
end;
end;

procedure TfmRicheditMsgBox.spbClick(Sender: TObject);
begin
showMultUser:=not showMultUser;
end;

procedure TfmRicheditMsgBox.createTv;
begin
FslUser:=TslUser.create(self);
Fsluser.Parent:=pnMuser;
Fsluser.Align:=alClient;
end;

procedure TfmRicheditMsgBox.tbFontClick(Sender: TObject);
begin
if FontDialog1.Execute then
CurrText.Assign(FontDialog1.Font);
end;

procedure TfmRicheditMsgBox.tbFaceClick(Sender: TObject);
begin
toolbar.SetFocus;
FFace.ShowBy(tbFace);
end;

procedure TfmRicheditMsgBox.onSelectFace(Sender: TObject);
begin
insertPicture(FFace.slFileName);
end;

procedure TfmRicheditMsgBox.InsertPicture(FName: string);
begin
editor.InsertGif(Fname);
end;

procedure TfmRicheditMsgBox.tbPictureClick(Sender: TObject);
begin
if opdialog.Execute then InsertPicture(opdialog.FileName);
end;

procedure TfmRicheditMsgBox.sendRvMsg;
var
stream: TStream;
buf: Pchar;
size: integer;
info: TBaseInfo;
s: string;
begin
Stream:=TMemoryStream.Create;
try
s:=Trim(Editor.Text);
[blue] if s = '' then S:='你有新信息，单击这里查阅...';
dm.WriteBaseInfo(info, dmMessage, s);
if Aname<>'' then info.user:=Aname;
Stream.WriteBuffer(info, sizeof(info));
Editor.Lines.SaveToStream(Stream);
size:=Stream.Size;
getMem(buf, size);
stream.Position:=0;
stream.ReadBuffer(buf^, Size);
// dm.UdpClient.Host:=dm.IPByUser(talkWith);
dm.UdpClient.Host:=TalkWithIP;
if dm.UdpClient.Host<>'' then
begin
if isSizeTooBig(size) then
begin
dm.sendMsgToServer(TalkWith, stream);
dm.sendPkInfo(dmReadFromSvr);
end else
dm.SendBuffer(buf^, size)
end
else
dm.SendMsgToServer(TalkWith, stream);
finally
FreeMem(buf, size);
Stream.Free;
end;[/blue]end;

class function TfmRicheditMsgBox.ExistMsgBox(Ip: string): TfmRicheditMsgBox;
var
i: integer;
begin
result:=nil;
for i:=0 to screen.FormCount-1 do
if screen.Forms is TfmRicheditMsgBox then
begin
if TfmRicheditMsgBox(screen.Forms).TalkWithIP=Ip then
begin
result:=TfmRicheditMsgBox(screen.forms);
break;
end;
end;
end;

procedure TfmRicheditMsgBox.Addhs;
var
s: string;
begin
reBuffer.Clear;
s:=CuserInfo.user+' '+formatDateTime('m&quot;月&quot;d&quot;日 &quot;hh:mmAM/PM', now);
reBuffer.Lines.Add(s);
reBuffer.DefAttributes.Color:=clGreen;
reBuffer.SelStart:=reBuffer.GetTextLen;
editCombine(reBuffer, editor);

{ editor.SelectAll;
editor.CopyToClipboard;
reBuffer.PasteFromClipboard;
}
//设置段落格式
reBuffer.SelectAll;
reBuffer.Paragraph.FirstIndent:=8;
reBuffer.SelStart:=0;
reBuffer.Paragraph.SpaceBefore:=6;
reBuffer.Paragraph.FirstIndent:=0;
editCombine(edhistory, reBuffer);
edHistory.Lines.Delete(edHistory.Lines.Count-1);

{ reBuffer.SelectAll;
reBuffer.CutToClipboard;
paste;
edHistory.Lines.Delete(edHistory.Lines.Count-1);
}
goBottom;
end;

procedure TfmRicheditMsgBox.mi(Sender: TObject; ACanvas: TCanvas; var Width,
Height: Integer);
begin
inc(width, 30);
inc(height, 2 + height Mod 2)
end;

procedure TfmRicheditMsgBox.adDrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; State: TOwnerDrawState);
begin
fmMain.SubItemDraw(sender, ACanvas, ARect, State);
end;

procedure TfmRicheditMsgBox.miCutClick(Sender: TObject);
begin
// rvEditor.CutDef;
end;

procedure TfmRicheditMsgBox.miCopyClick(Sender: TObject);
begin
//rvEditor.Copy;
end;

procedure TfmRicheditMsgBox.miPasteClick(Sender: TObject);
begin
// rvEditor.Paste;
end;

procedure TfmRicheditMsgBox.miFontClick(Sender: TObject);
begin
tbFontClick(nil);
end;

procedure TfmRicheditMsgBox.miSelectAllClick(Sender: TObject);
begin
//rvEditor.SelectAll;
end;

procedure TfmRicheditMsgBox.wmClose(var msg: TMessage);
begin
visible:=false;
end;

procedure TfmRicheditMsgBox.cmReceiveMsg(var message: Tmessage);
begin
FhaveNewMsg:=true;
Timer2.Enabled:=IsIconic(handle) and FhaveNewMsg;
end;

procedure TfmRicheditMsgBox.rvHsEditorContextPopup(Sender: TObject;
MousePos: TPoint; var Handled: Boolean);
var
select: boolean;
gif: TGraphic;
begin
{ gif:=rvhsEditor.GetSelectedImage;
hsSavePicAs.Enabled:=gif<>nil;
hsAddFace.Enabled:=(gif<>nil) and (gif is TGifImage)
and (gif.Height<80) and (gif.Width<80);
hsCopy.Enabled:=rvhsEditor.SelectionExists;
}
end;

procedure TfmRicheditMsgBox.hsSelectAllClick(Sender: TObject);
begin
//rvhsEditor.SelectAll;
end;

procedure TfmRicheditMsgBox.WmWndPosChange(var Msg: TWMWINDOWPOSCHANGING);
var
minx, miny: integer;
begin
miny:=300;
if showMultUser then minx:=480 else minx:=330;
Msg.WindowPos^.cx:=Max(Msg.WindowPos^.cx, minx);
Msg.WindowPos^.cy:=Max(Msg.WindowPos^.cy, miny);
end;

{ TslUser }
procedure TslUser.loadTv;
var
i: integer;
begin
inherited loadTv;
for i:=0 to cTv.Items.Count-1 do
if cTv.Items.Text=TfmRicheditMsgBox(Owner).TalkWith then
begin
TCheckTreeNode(cTv.Items).Checked:=true;
break;
end;
end;

procedure TfmRicheditMsgBox.SendRVMsgMult(users: TStrings);
var
stream: TStream;
buf: Pchar;
size: integer;
info: TBaseInfo;
i: integer;
offLineUser: string;
begin
{
Stream:=TMemoryStream.Create;
try
dm.WriteBaseInfo(info, dmMessage);
Stream.WriteBuffer(info, sizeof(info));
rvEditor.SaveRVFToStream(Stream, false);
size:=Stream.Size;
getMem(buf, size);
stream.Position:=0;
stream.ReadBuffer(buf^, Size);
// dm.UdpClient.Host:=dm.IPByUser(talkWith);

for i:=0 to users.Count-1 do
begin
dm.UdpClient.Host:=dm.IPByUser(users);
if dm.UdpClient.Host<>'' then
begin
if isSizeTooBig(size) then
begin
dm.sendMsgToServer(TalkWith, stream);
dm.sendPkInfo(dmReadFromSvr);
end else
dm.SendBuffer(buf^, size)
end
else
offLineUser:=offLineuser+getToken(users, 1, false, [#9]);
end;
if offLineUser<>'' then
begin
Stream.Write(buf^, size);
dm.sendMsgToServer(offLineUser, stream);
end;
if dm.UdpClient.Host<>'' then
dm.SendBuffer(buf^, size)
else
dm.SendMsgToServer(TalkWith, stream);
finally
FreeMem(buf, size);
Stream.Free;
end;
}
end;

procedure TfmRicheditMsgBox.hsSavePicAsClick(Sender: TObject);
var
image: TGraphic;
begin
{ image:=rvhsEditor.GetSelectedImage;
spd.Filter:=GraphicFilter(TGraphicClass(image.classtype));
spd.DefaultExt:=GraphicExtension(TGraphicClass(image.classtype));
if spd.Execute then image.SaveToFile(spd.FileName);
}
end;

procedure TfmRicheditMsgBox.srToolButton1Click(Sender: TObject);
begin
// TfmSendFileExe.CreateExe(TalkWith, dm.IPByUser(TalkWith));
TfmSendFileExe.CreateExe(TalkWith, TalkWithIP);
end;

procedure TfmRicheditMsgBox.Timer2Timer(Sender: TObject);
begin
FlashWindow(handle, true);
end;

procedure TfmRicheditMsgBox.FormResize(Sender: TObject);
begin
Timer2.Enabled:=IsIconic(handle) and FhaveNewMsg;
end;

function TfmRicheditMsgBox.CurrText: TRxTextAttributes;
begin
if Editor.SelLength = 0 then Editor.SelectAll;
Result := Editor.SelAttributes;
end;

procedure TfmRicheditMsgBox.EditorKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (ssCtrl in shift) and (key = VK_RETURN) then
begin
key:=0;
btReplyClick(nil);
end;
end;

procedure TfmRicheditMsgBox.AddMessage(From: string; AStream: TStream);
begin
//写上标题
reBuffer.Clear;
reBuffer.Lines.Add(From);
reBuffer.DefAttributes.Color:=clBlue;
// reBuffer.Paragraph.SpaceBefore:=6;
{ reBuffer.SelectAll;
reBuffer.CutToClipboard;
edHistory.SelStart:=length(edHistory.Text);
paste;
}

//写上内容
reBuffer.SelStart:=rebuffer.GetTextLen;
reBuffer.Lines.LoadFromStream(AStream);
reBuffer.SelectAll;
reBuffer.Paragraph.FirstIndent:=8;
reBuffer.SelStart:=0;
reBuffer.Paragraph.SpaceBefore:=6;
reBuffer.Paragraph.FirstIndent:=0;
editCombine(edHistory, reBuffer);
edHistory.Lines.Delete(edHistory.Lines.Count-1);
{ reBuffer.Lines.LoadFromStream(AStream);
reBuffer.SelectAll;
reBuffer.Paragraph.FirstIndent:=8;
reBuffer.SelectAll;
reBuffer.CutToClipboard;
paste;
}
goBottom;
FhaveNewMsg:=true;
Timer2.Enabled:=IsIconic(handle) and FhaveNewMsg;

end;

{
procedure TfmRicheditMsgBox.paste;
begin
edHistory.ReadOnly:=false;
try
edHistory.SelStart:=edHistory.GetTextLen;
edHistory.PasteFromClipboard;
finally
edHistory.ReadOnly:=true;
end;
end;
}
procedure TfmRicheditMsgBox.goBottom;
begin
edHistory.Perform(wm_vscroll, sb_Bottom, 0);
end;

procedure TfmRicheditMsgBox.FormDestroy(Sender: TObject);
begin
Stream.Free;
inherited;
end;

procedure TfmRicheditMsgBox.editCombine(edTarget, edSource: TRxRichedit);
var
smTg, smSr: TRichStreamModes;
begin
smtg:=edtarget.StreamMode;
smSr:=edSource.StreamMode;
try
stream.Clear;
edSource.StreamMode:=[];
edSource.Lines.SaveToStream(stream);
edTarget.StreamMode:=[smSelection];
stream.Position:=0;
edTarget.SelStart:=edTarget.GetTextLen;
edTarget.Lines.LoadFromStream(stream);
Stream.Clear;
finally
edSource.StreamMode:=smSr;
edTarget.StreamMode:=smTg;
end;
end;

procedure TfmRicheditMsgBox.EditorChange(Sender: TObject);
begin
btReply.Enabled:=Editor.GetTextLen>0;
end;

procedure TfmRicheditMsgBox.cNameClick(Sender: TObject);
begin
AName:=inputBox('改名','新名字','');
end;

initialization
RegisterClass(TGifImage);

end.

这个是发送，接收的 模块（包括其它数据库功能，因为我这个QQ只是 办公自动化系统的 小部分）
unit dmMain;

interface

uses
windows, messages, SysUtils, Classes, DB, ADODB, OleServer, Dialogs, myFunctions,
Notify, Controls, CommX, Menus, ExtCtrls, forms, ImgList, jpeg,
CoolTrayIcon, Graphics, IdUDPClient, IdBaseComponent, IdComponent,
IdUDPBase, IdUDPServer, IdSocketHandle, IdAntiFreezeBase, IdAntiFreeze,
ExtDlgs;

type

Tdm = class(TDataModule)
cn: TADOConnection;
Qry: TADOQuery;
Timer1: TTimer;
cTrayIcon: TCoolTrayIcon;
iml: TImageList;
pmenu: TPopupMenu;
N2: TMenuItem;
miSendMsg: TMenuItem;
miSendFile: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
miWordTo: TMenuItem;
UdpServer: TIdUDPServer;
UdpClient: TIdUDPClient;
IdAntiFreeze1: TIdAntiFreeze;
sp: TADOStoredProc;
spd: TSavePictureDialog;
psd: TPrinterSetupDialog;
mm: TImageList;
tmHint: TTimer;
miBc: TMenuItem;
miTest: TMenuItem;
procedure cnAfterConnect(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject);
procedure DataModuleCreate(Sender: TObject);
procedure tbexitClick(Sender: TObject);
procedure tbaboutClick(Sender: TObject);
procedure openMainClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure cTrayIconMouseEnter(Sender: TObject);
procedure drawitem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
State: TOwnerDrawState);
procedure mitem(Sender: TObject; ACanvas: TCanvas; var Width,
Height: Integer);
procedure N9Click(Sender: TObject);
procedure showMainForm(Sender: TObject);
procedure UdpServerUDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
procedure tmHintTimer(Sender: TObject);
procedure cTrayIconDblClick(Sender: TObject);
procedure miBcClick(Sender: TObject);
procedure miTestClick(Sender: TObject);
private
{ Private declarations }
UserList : TStringList;
function userIndex(user: string): integer;
function itemByUser(user: string): string;
procedure UserLogChange(user: string; Login: boolean);
procedure ReceiveFile(FileMsg: string);
procedure ReceiveMsg(Info: TBaseInfo; AStream: TStream);
procedure Read(AData: TStream);
procedure sendMsgToClick(Sender: TObject);
procedure sendFileToExe(Sender: TObject);
procedure checkImageOle;
procedure Broadcast(AStream: TStream);
public
{ Public declarations }
LocalIP : string;
// procedure SendCommand(HostIp, Cmd: string);
procedure login;
procedure logout;
procedure setColorMap(name: string);
procedure setMenu;
function IPByUser(user: string): string;
function ReConnected(askme: boolean): boolean;
function AllUser(asDeliteStr: boolean; exceptUser: string = ''): string;
procedure sendPkInfo(DlgMsg: TDlgMessage);
procedure sendMsgToServer(user: string; Stream: TStream);
procedure sendDocInfo(user, msg, table: string; Id: integer); overload;
procedure sendDocInfo(users: TStrings; msg, table: string; Id: integer); overload;
procedure WriteBaseInfo(var info: TBaseInfo; DlgMsg: TDlgMessage; msg: string = '');
procedure ReadMsgFromSever;
procedure AskForTranFiles(user, msg, Files: string);
procedure SendBuffer(var ABuffer; const AByteCount: integer);
procedure testMessage(Ip, Msg: string);
function CreateMenuItem(Aowner: TComponent; const ACaption: string; AShortCut: TShortCut;
AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; const AName: string): TMenuItem;
function NewMenuItem(Aowner: TComponent; const ACaption: string;
AOnClick: TNotifyEvent; AImageIndex: integer; const AName: string): TMenuItem;
end;

var
dm : Tdm;

implementation

uses frmMain, frmlogin, about, SendFileExe, SendFile, ReceiveFile,
RicEditmsgBox;

{$R *.dfm}

procedure Tdm.cnAfterConnect(Sender: TObject);
begin
LocalIP:=GetLocalIP;
end;

procedure Tdm.DataModuleDestroy(Sender: TObject);
var
i: integer;
begin
for I:=0 to screen.FormCount-1 do
if screen.Forms is TfmRicheditMsgBox then screen.Forms.Free;
logout;
FreeAndNil(UserList);
end;

procedure Tdm.DataModuleCreate(Sender: TObject);
var
cl: string;
begin
UserList:=TStringList.Create;
cl:=ReadIniStr('Lastuser', 'Colors');
setColorMap(cl);
UserList.DelimitedText:=AllUser(true);
setmenu;
checkImageOle;
end;


function Tdm.ReConnected(askme: boolean): boolean;
begin
if (not askme) or (messagebox(getactiveWindow, '连接已经断开，是否重新连接? ', '连接失败',
MB_YESNO or MB_ICONERROR)=IDYES) then
repeat
try
dobusy(true);
cn.Connected:=false;
cn.Connected:=true;
result:=true;
doBusy(false);
except
if messageBox(getActiveWindow, '重新连接失败...，是否重试？ ', '重新连接',
MB_ICONERROR or MB_YESNO) <> idYes then
begin
result:=false;
doBusy(false);
break;
end;
end;
until result=true;
end;


function Tdm.AllUser(asDeliteStr: boolean; exceptUser: string): string;
begin
result:='';
with qry do
begin
qry.Close;
SQL.Text:='select userName from Ausers';
Open;
while not qry.Eof do
begin
if Trim(FieldByName('userName').AsString) <> exceptUser then
if asDeliteStr then
begin
if result<>'' then
result:=Result+','+Trim(qry.fieldbyname('username').AsString)
else
result:=Trim(qry.fieldbyname('username').AsString);
end
else
result:=Result+Trim(qry.fieldbyname('username').AsString);
next;
end;
close;
end;
end;

procedure Tdm.tbexitClick(Sender: TObject);
begin
fmMain.Close;
end;

procedure Tdm.tbaboutClick(Sender: TObject);
begin
TaboutBox.Create(self,'关于',fmmain.handle).show;
end;

procedure Tdm.openMainClick(Sender: TObject);
begin
fmMain.showApplication:=true;
end;

procedure Tdm.sendMsgToClick(Sender: TObject);
var
MsgBox: TfmRicheditMsgBox;
cap: string;
ip: string;
begin
cap:=TmenuItem(Sender).Caption;
ip:=ipByuser(TmenuItem(Sender).Caption);
msgBox:=TfmRicheditMsgBox.ExistMsgBox(ip);
if msgBox=nil then
begin
msgBox:=TfmRicheditMsgBox.Create(self);
with msgBox do
begin
TalkWith:=cap;
talkWithIp:=Ip;
caption:='与'+cap+'交谈';
end;
end;
msgBox.visible:=true;
{ with msgBox do
begin
TalkWith:=cap;
talkWithIp:=Ip;
caption:='与'+cap+'交谈';
visible:=true;
end;
}
end;

function Tdm.userIndex(user: string): integer;
var
i: integer;
begin
result:=-1;
for i:= userList.Count-1 downto 0 do
if pos(user, userList)>0 then result:=i;
end;

procedure Tdm.setMenu;
var
i: integer;
m: TMenuitem;
begin
try
UserList.DelimitedText:=AllUser(true);
except
//
end;
for i:=miSendMsg.Count-1 downto 1 do miSendMsg.Items.Free;
miSendFile.Clear;
miWordTo.Clear;
for i:=0 to userList.Count-1 do
begin
m:=NewItem(getToken(userList, 1, false, ['^']), 0, false, true,
sendMsgToClick, 0, '');
m.OnAdvancedDrawItem:=drawitem;
m.OnMeasureItem:=mitem;
m.AutoHotkeys:=maManual;
if getToken(userList,2,false, ['^'])='' then
miWordTo.Add(m)
else
miSendMsg.Add(m);
m:=NewItem(getToken(userList, 1, false, ['^']), 0, false, true,
sendFileToExe, 0, '');
m.Visible:=false;
m.AutoHotkeys:=maManual;
miSendFile.Add(m);
m.OnAdvancedDrawItem:=drawitem;
m.OnMeasureItem:=mitem;
end;
end;

procedure Tdm.UserLogChange(user: string; Login: boolean);
var
i: integer;
s: string;
item: Tmenuitem;
begin
for i:=miSendFile.Count-1 downto 0 do
begin
s:=miSendFile.Items.Caption;
if pos('(', s)>1 then s:=copy(s, 1, pos('(', s)-1);
if s=user then miSendFile.Items.Visible:=Login;
end;
if not login then
begin
for i:=miSendMsg.Count-1 downto 0 do
begin
item:=miSendMsg.Items;
s:=item.Caption;
if pos('(', s)>1 then s:=copy(s, 1, pos('(', s)-1);
if s=user then
begin
miSendMsg.Delete(i);
miWordTo.Add(Item);
end;
end;
end
else
begin
for i:=miWordTo.Count-1 downto 0 do
begin
item:=miWordTo.Items;
s:=item.Caption;
if pos('(', s)>1 then s:=copy(s, 1, pos('(', s)-1);
if s=user then
begin
miWordTo.Delete(i);
miSendmsg.Add(Item);
end;
end;
end;
end;

procedure Tdm.Timer1Timer(Sender: TObject);
begin
setMenu;
dm.login;
// if Assigned(Mlist) then Mlist.updateData;
Timer1.Interval:=600000;
end;

procedure Tdm.sendFileToExe(Sender: TObject);
var
user: string;
begin
user:=TMenuItem(sender).Caption;
TfmSendFileExe.CreateExe(user, IPByUser(user));
end;

procedure Tdm.ReceiveFile(FileMsg: string);
var
user: string;
Files: string;
msg: string;
begin
user:=getToken(Filemsg, 2, false, ['^']);
files:=getToken(Filemsg, 3, false, ['^']);
msg:=getToken(Filemsg, 4, true, ['^']);
TfmReceiveFile.CreateExe(user, IPByUser(user), Files, msg);
end;

function Tdm.IPByUser(user: string): string;
begin
Result:=getToken(itemByUser(user), 2, false, ['^']);
end;

function Tdm.itemByUser(user: string): string;
var
i: integer;
begin
result:='';
for i:=0 to userList.Count-1 do
begin
if pos(user, userList)>0 then
begin
result:=userList;
break;
end;
end;
end;

procedure Tdm.cTrayIconMouseEnter(Sender: TObject);
begin
if not MsgShow then slideShowMsg;
end;

procedure Tdm.setColorMap(name: string);
begin
qry.SQL.Text:='Select * from ColorMap where name = '+quotedStr(name);
qry.Open;
if qry.RecordCount>0 then
begin
clbegin := qry.fieldByName('clBegin').AsInteger;
clEnd := qry.fieldByName('clEnd').AsInteger;
clslBegin := qry.fieldByName('clslBegin').AsInteger;
clslEnd := qry.fieldByName('clslEnd').AsInteger;
end
else
begin
clbegin := $00FBF0EA;
clEnd := $00E2A981;
clslBegin := $00D9F1FF;
clslEnd := $0026ACFD;
end;
clMenuItem := clBegin;
clMenuSide := getAlphaColor(clEnd, clWhite, TranspValue);
clSelected := getAlphaColor(clMenuItem, clslEnd, TranspValue);
clmsSelect := getAlphaColor(clMenuSide, clslEnd, TranspValue);
clPanelFrame := getAlphaColor(clGray, clEnd, 128);
clDark := getAlphaColor(clEnd, clblack, 64);
clWorkArea := getAlphaColor(clAppWorkSpace, clEnd, 16);
clslitem := getAlphaColor(clWhite, clslEnd, TranspValue);
qry.Close;
end;

procedure Tdm.drawitem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
State: TOwnerDrawState);
begin
SubMenuItemDraw(sender, Acanvas, ARect, State);
end;

procedure Tdm.mitem(Sender: TObject; ACanvas: TCanvas; var Width,
Height: Integer);
begin
inc(width, 45);
inc(height, 2 + height Mod 2)
end;

procedure Tdm.N9Click(Sender: TObject);
begin
fmmain.Close;
end;

procedure Tdm.showMainForm(Sender: TObject);
begin
fmMain.showApplication:=true;
end;

procedure Tdm.sendPkInfo(DlgMsg: TDlgMessage);
var
info: TbaseInfo;
begin
writebaseInfo(info, DlgMsg);
SendBuffer(info, sizeof(info));
end;

procedure Tdm.ReceiveMsg(Info: TBaseinfo; AStream: TStream);
var
cap: string;
frm: TfmRicheditMsgBox;
s: string;
lines: TStrings;
begin
cap:='与'+info.user+'交谈';
AStream.Position:=sizeof(info);
frm:=TfmRicheditMsgBox.ExistMsgBox(info.ip);
if frm=nil then
frm:=TfmRicheditMsgBox.Create(nil);
frm.TalkWith:=info.user;
frm.TalkWithIP:=info.ip;
frm.caption:=cap;
frm.AddMessage(info.user+' '+formatDateTime('m&quot;月&quot;d&quot;日 &quot;hh:mmAM/PM', info.Date),
AStream);
if not frm.Visible then TfmNotify.showMsgInfo(info);
end;

procedure Tdm.UdpServerUDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
begin
Read(AData);
end;

procedure Tdm.sendMsgToServer(user: string; Stream: TStream);
begin
qry.SQL.Text:='select top 0 * from msgSvr';
qry.Open;
qry.Edit;
TBlobField(qry.FieldByName('context')).LoadFromStream(Stream);
qry.FieldByName('unReadPerson').AsString:=user;
qry.Post;
qry.Close;
end;

procedure Tdm.sendDocInfo(user, msg, table: string; Id: integer);
var
info: TbaseInfo;
Docinfo: TDocInformation;
buf: pchar;
size: integer;
stream: TStream;
begin
WriteBaseInfo(info, dmDocInfo, msg);
DocInfo.Table:=table;
DocInfo.RecID:=Id;
size:=Sizeof(info)+sizeof(DocInfo);
getMem(buf, size);
Stream:=TMemoryStream.Create;
try
move(info, pchar(integer(buf))^, sizeof(info));
move(DocInfo, PChar(integer(buf)+sizeof(info))^, sizeof(DocInfo));
UdpClient.Host:=IPByUser(user);
if UdpClient.Host<>'' then
SendBuffer(buf^, size)
else
begin
Stream.Write(buf^, size);
sendMsgToServer(user, stream);
end;
finally
FreeMem(buf, size);
Stream.Free;
end;
end;

procedure Tdm.WriteBaseInfo(var info: TBaseInfo; DlgMsg: TDlgMessage; msg: string = '');
begin
info.Date:=now;
info.dlg:=DlgMsg;
info.user:=CuserInfo.user;
info.ip:=LocalIP;
info.msg:=msg;
end;

procedure Tdm.sendDocInfo(users: TStrings; msg, table: string;
Id: integer);
var
info: TbaseInfo;
Docinfo: TDocInformation;
buf: pchar;
size: integer;
i: integer;
offLineUser: string;
stream: TStream;
begin
WriteBaseInfo(info, dmDocInfo, msg);
DocInfo.Table:=table;
DocInfo.RecID:=Id;
size:=Sizeof(info)+sizeof(DocInfo);
getMem(buf, size);
Stream:=TMemoryStream.Create;
try
move(info, pchar(integer(buf))^, sizeof(info));
move(DocInfo, PChar(integer(buf)+sizeof(info))^, sizeof(DocInfo));
for i:=0 to users.Count-1 do
begin
UdpClient.Host:=IPByUser(users);
if UdpClient.Host<>'' then
SendBuffer(buf^, size)
else
offLineUser:=offLineuser+getToken(users, 1, false, ['^']);
end;
if offLineUser<>'' then
begin
Stream.Write(buf^, size);
sendMsgToServer(offLineUser, stream);
end;
finally
Stream.Free;
FreeMem(buf, size);
end;
end;

procedure Tdm.ReadMsgFromSever;
var
i: integer;
stream: TMemoryStream;
begin
sp.Parameters.ParamByName('@User').Value:=CuserInfo.user;
sp.Open;
Stream:=TMemoryStream.Create;
try
while not sp.Eof do
begin
Stream.Clear;
TBlobField(sp.FieldByName('Context')).SaveToStream(Stream);
Read(Stream);
sp.Next;
end;
finally
stream.Free;
sp.Close;
end;
end;

procedure Tdm.Read(AData: TStream);
var
Info: TBaseInfo;
DocInfo: TDocInformation;
Files: array[0..1024] of char;
begin
fillChar(info, sizeof(info), 0);
AData.Position:=0;
AData.ReadBuffer(info, sizeof(info));
case info.dlg of
dmLogin:
begin
UdpClient.Host:=info.ip;
sendPkInfo(dmOnLine);
if userIndex(info.user)<>-1 then
userList[userIndex(info.user)]:=info.user+'^'+info.ip;
UserLogChange(info.user, true);
end;
dmOnLine:
begin
if userIndex(info.user)<>-1 then
userList[userIndex(info.user)]:=info.user+'^'+info.ip;
UserLogChange(info.user, true);
end;

dmOffLine:
if userList<>nil then
begin
if userIndex(info.user)<>-1 then
userList[userIndex(info.user)]:=info.user;
UserLogChange(info.user, false);
end;

dmRefresh:
begin

end;
//
dmMessage:
begin
ReceiveMsg(info, AData);
end;

dmDocInfo:
begin
Adata.Position:=sizeof(info);
Adata.ReadBuffer(DocInfo, sizeof(Docinfo));
TfmNotify.ShowDocInfo(info, DocInfo);
end;

dmBroadcast:
begin
Broadcast(AData);
end;

dmFileTrans:
if findWindow('TfmReceiveFile', nil)=0 then
begin
AData.Position:=sizeof(info);
Adata.Read(Files, Adata.Size-sizeof(info));
TfmReceiveFile.CreateExe(info.user, info.ip, Files, info.msg);
end;

dmReadFromSvr: ReadMsgFromSever;

end;
end;

procedure Tdm.AskForTranFiles(user, msg, Files: string);
var
info: TBaseInfo;
buf: pchar;
Stream: TStream;
size: integer;
begin
size:=sizeof(info)+length(Files);
Stream:=TMemoryStream.Create;
GetMem(buf, size);
Try
writeBaseInfo(info, dmFileTrans, msg);
Stream.WriteBuffer(info, sizeof(info));
Stream.Writebuffer(pchar(Files)^, length(Files));
Stream.Position:=0;
Stream.ReadBuffer(buf^, size);
udpClient.Host:=IpByuser(user);
SendBuffer(buf^, size);
finally
FreeMem(buf, size);
Stream.Free;
end;
end;

procedure Tdm.login;
begin
UdpClient.Host:=BroadCastIp;
sendPkInfo(dmLogin);
end;

procedure Tdm.logout;
begin
try
UdpClient.Host:=BroadCastIp;
sendPkInfo(dmOffline);
except
abort;
end
end;

procedure Tdm.tmHintTimer(Sender: TObject);
begin
if tmHint.Enabled then
begin
tmHint.Enabled:=false;
hideTip;
end;
end;

procedure Tdm.cTrayIconDblClick(Sender: TObject);
begin
fmMain.showApplication:=true;
end;

procedure Tdm.checkImageOle;
var
sysdir: string;
buf: array[0..254] of char;
begin
GetSystemDirectory(buf, 255);
sysdir:=strPas(buf);
if not FileExists(sysdir+'/GdiPlus.dll') then
begin
qry.Close;
qry.SQL.Text:='select PC from upGrade where Rtrim(pName) = ''GdiPlus.dll''';
qry.Open;
TBlobField(qry.FieldByName('pc')).SaveToFile(sysdir+'/GdiPlus.dll');
qry.Close;
end;
if not FileExists(sysdir+'/ImageOle.dll') then
begin
qry.Close;
qry.SQL.Text:='select PC from upGrade where Rtrim(pName) = ''ImageOle.dll''';
qry.Open;
TBlobField(qry.FieldByName('pc')).SaveToFile(sysdir+'/ImageOle.dll');
qry.Close;
// if FileExists(sysdir+'ImageOle/.dll') then
winexec(pchar(sysdir+'/RegSvr32 '+sysdir+'/imageOle.dll'), SW_HIDE);
end;
end;

procedure Tdm.SendBuffer(var ABuffer; const AByteCount: integer);
begin
try
UdpClient.SendBuffer(Abuffer, AByteCount);
except
raise Exception.Create('网络错误，无法将信息发送给对方');
end;
end;

procedure Tdm.miBcClick(Sender: TObject);
begin
testMessage(BroadCastIP, 'BroadCast test message');
end;

procedure Tdm.Broadcast(AStream: TStream);
var
info: TbaseInfo;
msg: string;
s: string;
begin
Astream.Position:=0;
Astream.ReadBuffer(info, sizeof(info));
s:=info.user+'('+info.ip+')';
dm.cTrayIcon.ShowBalloonHint(s, info.msg, bitInfo, 20);
end;

procedure Tdm.miTestClick(Sender: TObject);
begin
testMessage(inputBox('IP', '输入地址', ''), 'Test Connect');;
end;

procedure Tdm.testMessage(Ip, Msg: string);
var
info: TBaseInfo;
begin
WriteBaseInfo(info, dmBroadcast);
info.msg:=msg;
UdpClient.Host:=Ip;
SendBuffer(info, sizeof(info));
end;

function Tdm.CreateMenuItem(Aowner: TComponent; const ACaption: string;
AShortCut: TShortCut; AChecked, AEnabled: Boolean;
AOnClick: TNotifyEvent; const AName: string): TMenuItem;
begin
Result := TMenuItem.Create(Aowner);
with Result do
begin
Caption := ACaption;
ShortCut := AShortCut;
OnClick := AOnClick;
Checked := AChecked;
Enabled := AEnabled;
name:=AName;
OnAdvancedDrawItem:=drawitem;
result.OnMeasureItem:=mitem;
end;
end;

function Tdm.NewMenuItem(Aowner: TComponent; const ACaption: string;
AOnClick: TNotifyEvent; AImageIndex: integer;
const AName: string): TMenuItem;
begin
Result := TMenuItem.Create(Aowner);
with Result do
begin
Caption := ACaption;
OnClick := AOnClick;
name:=AName;
ImageIndex:=AImageIndex;
OnAdvancedDrawItem:=drawitem;
result.OnMeasureItem:=mitem;
end;
end;

end.

也在忙这个，学习

非常感谢xuxiaohan!!!
请到这儿http://www.delphibbs.com/delphibbs/dispq.asp?lid=3653080再领取200分.