Delphi控件源码

开发平台：
Delphi

RealMessengerUnit.pas：源码内容
							unit RealMessengerUnit;
interface
uses
  Classes,ComCtrls,Messages, Gauges,StdCtrls,StrUtils, ExtCtrls, SysUtils, Controls,Contnrs,
  Windows, Registry,Graphics, Math, Forms,Global,Dialogs,MSHtml,md5,UrlMon,ChatingFrm,MMSystem,WinSock,
  MMregs,MMUtils,VFW,JPeg,ShlObj,ShDocVw,WNDES,NB30,VideoConsts,ShellAPI,XMLDoc,Color,MySocket,bsSkinCtrls;
type
  TTransmitFileCategory = (tfSend,tfGet);
  TTransmitFile = class
    public
      FileName,
      SaveFileName      :String;
      FileSize          :Int64;
      FileHashCode      :String;
      FileStream        :TFileStream;
      SenderID          :Integer;
      SenderName        :String;
      ReceiverID        :Integer;
      ReceiverName      :String;
      Category          :TTransmitFileCategory;
      IsAccepted,                      
      IsComleted        :Boolean;      
      CurentSize        :Int64;        
      Errors            :Integer;
      StartTime         :Cardinal;     
      OldUsedTime       :Cardinal;     
      UsedTime          :Cardinal;     
      ChatingForm       :TChatingForm; 
      ImageID,
      PercentID,                       
      CompletedID,                     
      UndoneID,                        
      ActionID          :String;       
      BaseID            :String;       
      Employee          :PEmployee;    
      IsScreen          :Boolean;      
      SendFileThread    :TThread;      
      FileTable         :TList;        
      Speed             :Integer;      
      ResumedSize       :Integer;
      OnMovingFile      :Boolean;
      MySocket          :TMySocket;
      SleepValue        :Real;
      LastGetOrResultTicket:Cardinal;
      Constructor Create(vCategory   :TTransmitFileCategory;
                       vSenderID     :Integer;
                       vSenderName   :String;
                       vReceiverID   :Integer;
                       vReceiverName :String;
                       vFileName     :String;
                       vChatingForm  :TChatingForm;
                       ReceiverLocalIP:String;
                       ReceiverLocalPort:Integer;
                       ReceiverIP:String;
                       ReceiverPort:Integer;
                       vFileSize     :Int64=0;
                       vFileHashCode :String='';
                       vBaseID       :String='';
                       vIsScreen     :Boolean=False
                       );
      Destructor Destroy();Override;
      procedure CreateHTML();
      procedure Cancel();
      procedure Error();
      procedure Decline();
      procedure Accept();
      procedure Stop(StopID:Integer);
      procedure Send(AcceptedSize:Int64);
      procedure Get(SendTicket:Int64);
      procedure ShowProgress();
      procedure ShowComplete();
      procedure Close();
      procedure Logout();
  end;
  TSendFile = class(TThread)      
    private
      procedure CopyFileTable;    
      procedure ShowCompleted;    
      procedure ShowError;        
    protected
      procedure Execute; override;
    public
      ReceiverID:Integer;         
      BaseID:String;              
      FileStream:TFileStream;     
      FileTable:TList;            
      TransmitFile:TTransmitFile;
      constructor Create(vReceiverID:Integer;vBaseID:String;vFileStream:TFileStream;vTransmitFile:TTransmitFile);
      destructor Destroy;override;
  end;
  TMoveFile = class(TThread)
    private
      procedure ShowCompleted;   
      procedure ShowMoving;
    protected
      procedure Execute; override;
    public
      TransmitFile:TTransmitFile;
      constructor Create(vTransmitFile:TTransmitFile);
  end;
  TSendVideo = class(TThread)
    private
      KeyFrame: Boolean;
      SendBuffer:Array[1..2048]of char;
      procedure SendVideoBuffer;
    protected
      procedure Execute; override;
    public
  end;
  PFileTableUnit = ^TFileTableUnit;
  TFileTableUnit = record
    IsAccepted:char;
  end;
  TAudioHandShakeCategory = (ahRequest,ahResponse);
  TAudioHandShake = class
    public
      Category    :TAudioHandShakeCategory;
      ID          :Integer;      
      Name        :String;       
      ChatingForm :TChatingForm;
      ImageID,
      ActionID,
      BaseID      :String;
      IsAccepted  :Boolean;
      MySocket    :TMySocket;
      LastGetTicket:Cardinal;
      Constructor Create(vCategory:TAudioHandShakeCategory;
                         vID:Integer;
                         vName:String;
                         vChatingForm:TChatingForm;
                         ReceiverLocalIP:String;
                         ReceiverLocalPort:Integer;
                         ReceiverIP:String;
                         ReceiverPort:Integer
                         );
      Destructor Destroy();Override;
      procedure CreateHTML();
      procedure Cancel();
      procedure Decline();
      procedure Accept();
      procedure Stop(StopID:Integer);
      procedure Close();
      procedure Logout();
  end;
  TVideoHandShakeCategory = (vhRequest,vhResponse);
  TVideoHandShake = class
    public
      Category    :TVideoHandShakeCategory;
      ID          :Integer;      
      Name        :String;       
      ChatingForm :TChatingForm;
      ImageID,
      ActionID,
      BaseID      :String;
      IsAccepted  :Boolean;
      VideoData   :TVideoDataInfo;
      GetedData   :Int64;
      GetedFrame  :Int64;
      StartTicket :Int64;
      PDC         :HDC;
      SendVideo   :TSendVideo;
      AMySocket   :TMySocket;
      VMySocket   :TMySocket;
      ALastGetTicket:Cardinal;
      VLastGetTicket:Cardinal;
      Constructor Create(vCategory:TVideoHandShakeCategory;
                         vID:Integer;
                         vName:String;
                         vChatingForm:TChatingForm;
                         AReceiverLocalIP:String;
                         AReceiverLocalPort:Integer;
                         AReceiverIP:String;
                         AReceiverPort:Integer;
                         VReceiverLocalIP:String;
                         VReceiverLocalPort:Integer;
                         VReceiverIP:String;
                         VReceiverPort:Integer
                         );
      Destructor Destroy();Override;
      procedure CreateHTML();
      procedure Cancel();
      procedure Decline();
      procedure Accept();
      procedure Stop(StopID:Integer);
      procedure Close();
      procedure Logout();
  end;
  PReceivedMsgID = ^TReceivedMsgID;
  TReceivedMsgID = record
    Sender,
    SendTicket:Cardinal;
  end;
  TProxyCategory = (pcNone,pcSocks4,pcSocks4A,pcSocks5,pcHTTP);
  TZoomAction = (zaMinimize, zaMaximize);
  procedure ZoomEffect(theForm: TForm; theOperation: TZoomAction);
  function  OpenChatingForm(Room:ChatRoom;OpenNew:Boolean = True):TChatingForm;
  function  FindEmployeeByID(ID:Integer):PEmployee;
  function  FilterHTMLCode(HTML:String):String;
  function  FindTransmitFileByBaseID(BaseID:String):TTransmitFile;
  function  FindAudioHandShakeByBaseID(BaseID:String):TAudioHandShake;
  function  FindAudioHandShakeByID(ID:Integer):TAudioHandShake;
  function  FindVideoHandShakeByBaseID(BaseID:String):TVideoHandShake;
  function  FindVideoHandShakeByID(ID:Integer):TVideoHandShake;
  procedure PlayEventSound(FileName:string);
  procedure FocusForm(form:TForm);
  function  GetHostIP(HostName: String): String;
  function  ACMBuildWaveHeader:PGSM610WaveFormat;
  function  GetSpecialFolderDir(const folderid:integer):string;
  procedure SaveHistory(CBMessage:TCBMessage);
  procedure InsertHTML(ChatingForm:TChatingForm;IE:TWebbrowser;HTML:String);
  procedure ShowMsg(ChatingForm:TChatingForm;IE:TWebbrowser;SenderName:String;CBMessage:TCBMessage;Save:Boolean=True);
  function jfForceForeGroundWindow(hwnd: THandle): boolean;
  function GetNetBIOSAddress: string;
  function HostToIP(Name: string; var Ip: string): Boolean;
  procedure ChangeAllColor(CustColor:TColor);
  procedure ChangeChatingFormColor(ChatingForm:TChatingForm;CustColor:TColor);
  procedure FillBitmapStruc;
  procedure CompareFrame(lpVHdr: PVIDEOHDR);
  procedure InitCompressor;
  procedure UnInitCompressor;
var
  A_FCV: TCOMPVARS;
  A_FInInfo: TBitmapInfo;
  A_FOutInfo: TBitmapInfo;
  FCV: TCOMPVARS;
  FInInfo: TBitmapInfo;
  FOutInfo: TBitmapInfo;
  FCaptureHandle: THandle;
  FSampleNum: DWORD;
  FOutActSize: DWORD;
  FOutFormatSize: DWORD;
  FOutBufferSize: DWORD;
  
  FOutBuf: PByte;
  FOutBufSize: DWORD;
  A_FOutFormatSize: DWORD;
  AudioLastRestartTime:Cardinal;
  
  OnlineNode,
  OfflineNode       :TTreeNode;
  ThreadHandle      :THandle;
  wfx               :TWaveFormatEx;
  LastReturnHartTick:Cardinal;
  OldMousePoint,
  OldCursorPoint    :TPoint;
  Snoop             :Int64;
  IsAutoState       :Boolean;
  DESKEY            :String='NewRealMessenger';
  MsgAlertQueue     :TList;                
  MySockets,
  ReceivedMessages,                        
  MsgReturnCheck,                          
  Branchs,                                 
  Employees,                               
  TransmitFiles,                           
  AudioHandShakes,                         
  VideoHandShakes,                         
  lpVHdrs            :Classes.TThreadList; 
  Me                 :PEmployee;           
  LoginName          :String='';           
  Password           :String='';           
  LoginState         :String='联机';
  HostName           :String='';
  HostIP             :String='';           
  ServerPort         :Integer=0;           
  MsgSound           :String='Type.wav';   
  DontPlaySound      :Boolean=False;       
  AutoConnectInterval:Integer=180;         
  DontAutoConnect    :Boolean=False;       
  ProxyCategory      :TProxyCategory;
  ProxyAddress       :String='';
  ProxyPort          :Integer=0;           
  ProxyUsername      :string='';           
  ProxyPassword      :string='';
  AppKey            :String='Softwareimp2p.Netim';
  StartColor        :TColor = clWhite;     
  EndColor          :TColor = 13816530;{12307877;}
  DefaultColor      :TColor = 13816530;{12307877;}
  SysTextColor      :String = '#545454';   
  CssColor          :String='ButtonFace';  
  MACNO             :String;               
  ResPath,                                 
  MyDocumentPath,                          
  ApplicationPath,                         
  CachePath,                               
  HistoryPath,                             
  SoundPath,                               
  PicPath           :String;               
  ActiveChatingForm :TChatingForm;
  AudioReceiverID   :Integer=0;            
  AudioMySocket     :TMySocket;            
  VideoReceiverID   :Integer=0;            
  VideoMySocket     :TMySocket;            
  HaveAudioDevice,                         
  HaveVideoDevice   :Boolean;              
  pwfx              :PGSM610WaveFormat;    
  ImgListMain       :TImageList;           
  TVMain            :TBSSkinTreeView;      
  ChatingFormList   :TList;                
  performancefrequency_s :Int64;           
  performancefrequency_ms:Single;
implementation
uses
  SelFaceFrm,MsgFrm,ZLib,RealMessengerImpl,VideoFrm;
{------------------------------------------------------------------------------}
procedure TSendVideo.SendVideoBuffer;
begin
    VideoMySocket.SendBuffer(SendBuffer,SizeOf(TCBVideo)+1);
end;
{------------------------------------------------------------------------------}
procedure TSendVideo.Execute;
var
  Buffer: PByte;
  iLoop:Integer;
  CBVideo:TCBVideo;
  Position:Integer;
  AllBuffer:Array[0..8180]of char;
  lpVHdr: PVIDEOHDR;
begin
  FreeOnTerminate:=True;
  while not Terminated do
  begin
    with lpVHdrs.LockList do
    try
      if Count>1 then
      begin
        lpVHdr:=Items[0];
        Remove(lpVHdr);
      end
      else
      begin
        sleep(10);
        continue;
      end;
    finally
      lpVHdrs.UnlockList;
    end;
    
    FOutActSize := FInInfo.bmiHeader.biSizeImage;
    try
      Application.ProcessMessages;
      Buffer := ICSeqCompressFrame(@FCV, 0, lpVHdr^.lpData, @KeyFrame, @FOutActSize);
    except
      continue;
    end;
    if FOutActSize < 8180 then
    begin
      FillChar(CBVideo, SizeOf(TCBVideo), 0);
      CBVideo.Sender:=Me.ID;
      CBVideo.Receiver:=VideoReceiverID;
      CBVideo.bKeyFrame := KeyFrame;
      CBVideo.nSampleNum := FSampleNum;
      CBVideo.nAllSize := FOutActSize;
      FillChar(AllBuffer, SizeOf(AllBuffer), 0);
      Move(Buffer^,AllBuffer,FOutActSize);
      if FOutActSize mod SizeOf(CBVideo.Buf) = 0 then
        CBVideo.PackCount:=FOutActSize div SizeOf(CBVideo.Buf)
      else
        CBVideo.PackCount:=FOutActSize div SizeOf(CBVideo.Buf)+1;
      Position:=0;
      for iLoop:=1 to CBVideo.PackCount do
      begin
        CBVideo.PackNO:=iLoop;
        if FOutActSize - Position >= SizeOf(CBVideo.Buf) then
        begin
          CBVideo.bufLength:=SizeOf(CBVideo.Buf);
          CopyMemory(@CBVideo.Buf[1],@AllBuffer[Position],SizeOf(CBVideo.Buf));
        end
        else
        begin
          CBVideo.bufLength:=FOutActSize - Position;
          CopyMemory(@CBVideo.Buf[1],@AllBuffer[Position],FOutActSize - Position);
        end;
        Position:=Position+CBVideo.bufLength;
        SendBuffer[1]:=skVideo;
        CopyMemory(@SendBuffer[2],@CBVideo,SizeOf(CBVideo));
        //Synchronize(SendVideoBuffer);
        SendVideoBuffer;
        Sleep(50);
      end;
      Inc(FSampleNum);
    end;
  end;//while
end;
procedure TSendFile.Execute;
var
  CBSendFilePackage:TCBSendFilePackage;
  SendFileCompleted:TCBSendFileCompleted;
  Buffer:Array[1..2048]of char;
  AllIsSended:Boolean;
  iLoop:Integer;
  FileTableUnit:PFileTableUnit;
  SendCount:Integer;
  LastSpeed:Integer;
	Context: MD5Context;
  performancecounter,performancecounter1,performancecounter2:Int64;
begin
  FreeOnTerminate:=True;
  AllIsSended:=False;
  SendCount:=0;
  while (not AllIsSended) do
  begin
    if Terminated then exit;
    if SendCount>20 then
    begin
      Synchronize(ShowError);
      exit;
    end;
    AllIsSended:=True;
    
    Synchronize(CopyFileTable);
    
    with FileTable do
    for iLoop:=0 to Count-1 do
    begin
      try
        if Terminated then exit;
        FileTableUnit:=Items[iLoop];
        if FileTableUnit.IsAccepted='0' then
        begin
          AllIsSended:=False;
          FileStream.Position:=iLoop*FilePackSize;
          CBSendFilePackage.Position:=FileStream.Position;
          if FileStream.Size - FileStream.Position  > FilePackSize then
          begin
            FileStream.Read(CBSendFilePackage.Package,FilePackSize);
            CBSendFilePackage.Length:=FilePackSize;
          end
          else
          begin
            FileStream.Read(CBSendFilePackage.Package,FileStream.Size - CBSendFilePackage.Position);
            CBSendFilePackage.Length:=FileStream.Size - CBSendFilePackage.Position;
          end;
          CBSendFilePackage.Receiver:=ReceiverID;
          CBSendFilePackage.BaseID:=BaseID;
	        MD5Init(Context);
	        MD5Update(Context, PChar(@CBSendFilePackage.Package[1]), CBSendFilePackage.Length);
	        MD5Final(Context, CBSendFilePackage.MD5CODE);
          queryperformancecounter(performancecounter);
          CBSendFilePackage.SendTicket:=performancecounter;
          Buffer[1]:=skSendFilePackage;
          CopyMemory(@Buffer[2],@CBSendFilePackage,SizeOf(CBSendFilePackage));
          TransmitFile.MySocket.SendBuffer(Buffer,SizeOf(CBSendFilePackage)+1);
          if TransmitFile.SleepValue>0 then
          begin
            queryperformancecounter(performancecounter1);
            repeat
              if TransmitFile.SleepValue>performancefrequency_ms*2 then Sleep(1);
              queryperformancecounter(performancecounter2);
            until performancecounter2-performancecounter1>=TransmitFile.SleepValue;
          end;
        end;
      except
      end;
    end;
  end;
  Synchronize(ShowCompleted);
end;
procedure TSendFile.CopyFileTable;
var
  iLoop:Integer;
  FileTableUnit:PFileTableUnit;
begin
  for iLoop:=0 to FileTable.Count-1 do
  begin
    FileTableUnit:=FileTable.Items[iLoop];
    FreeMem(FileTableUnit,SizeOf(TFileTableUnit));
  end;
  FileTable.Clear;
  for iLoop:=0 to TransmitFile.FileTable.Count-1 do
  begin
    GetMem(FileTableUnit,SizeOf(TFileTableUnit));
    FileTableUnit.IsAccepted:=PFileTableUnit(TransmitFile.FileTable.Items[iLoop]).IsAccepted;
    FileTable.Add(FileTableUnit);
  end;
end;
procedure TSendFile.ShowError;
begin
  TransmitFile.Error;
end;
procedure TSendFile.ShowCompleted;
begin
  TransmitFile.ShowComplete;
end;
destructor TSendFile.Destroy;
var
  iLoop:Integer;
  FileTableUnit:PFileTableUnit;
begin
  inherited Destroy;
  for iLoop:=0 to FileTable.Count-1 do
  begin
    FileTableUnit:=FileTable.Items[iLoop];
    FreeMem(FileTableUnit,SizeOf(TFileTableUnit));
  end;
  FileTable.Clear;
  FileTable.Free;
end;
constructor TSendFile.Create(vReceiverID:Integer;vBaseID:String;vFileStream:TFileStream;vTransmitFile:TTransmitFile);
begin
  inherited Create(True);
  ReceiverID:=vReceiverID;
  BaseID:=vBaseID;
  FileStream:=vFileStream;
  FileStream.Position:=0;
  FileTable:=TList.Create;
  TransmitFile:=vTransmitFile;
  Resume;
end;
{------------------------------------------------------------------------------}
constructor TMoveFile.Create(vTransmitFile:TTransmitFile);
begin
  inherited Create(True);
  FreeOnTerminate:=True;
  TransmitFile:=vTransmitFile;
  if TransmitFile.OnMovingFile then
  begin
    Terminate;
    Exit;
  end;
  TransmitFile.OnMovingFile:=True;
  Resume;
end;
{------------------------------------------------------------------------------}
procedure TMoveFile.ShowMoving;
var
  E:IHTMLElement;
begin
  with TransmitFile do
  begin
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(CompletedID,0) as IHTMLElement;
    E.style.width:='100%';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(UndoneID,0) as IHTMLElement;
    E.style.width:='0%';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
    E.innerHTML:='传输完毕（正在移动文件...）';
  end;
end;
{------------------------------------------------------------------------------}
procedure TMoveFile.Execute;
var
  Buffer:Array[1..FilePackSize] of char;
  BufferSize:Integer;
  iLoop:Integer;
  SaveFileStream:TFileStream;
begin
    with TransmitFile do
    if Category = tfGet then
    begin
      try
        if not IsScreen then
        begin
          Synchronize(ShowMoving);
          FileStream.Position:=FileTable.Count;
        end
        else
          FileStream.Position:=0;
        try
          SaveFileStream:=TFileStream.Create(SaveFileName,fmCreate or fmShareDenyWrite);
          for iLoop:=0 to FileTable.Count-1 do
          begin
            if FileStream.Size-FileStream.Position>SizeOf(Buffer) then
              BufferSize:=SizeOf(Buffer)
            else
              BufferSize:=FileStream.Size-FileStream.Position;
              
            FileStream.Read(Buffer,BufferSize);
            SaveFileStream.Write(Buffer,BufferSize);
          end;
        finally
          SaveFileStream.Free;
          SaveFileStream:=nil;
          FileStream.Free;
          FileStream:=nil;
        end;
        try
          DeleteFile(PChar(CachePath+''+FileHashCode));
        except
        end;
      except
        on E: Exception do
        begin
          MessageBox(ChatingForm.handle,PChar(E.message),'错误',MB_ICONERROR);
          exit;
        end;
      end;
    end;
    Synchronize(ShowCompleted);
end;
{------------------------------------------------------------------------------}
procedure TMoveFile.ShowCompleted;
begin
  TransmitFile.ShowComplete;
end;
{------------------------------------------------------------------------------}
procedure UnInitCompressor;
begin
  if FCV.hic <> 0 then
  begin
    ICSeqCompressFrameEnd(@FCV);
    ICCompressorFree(@FCV);
    ICClose(FCV.hic);
  end;
end;
  
{------------------------------------------------------------------------------}
procedure FillBitmapStruc;
begin
  FillChar(FInInfo.bmiHeader, SizeOf(TBitmapInfoHeader), 0);
  with FInInfo.bmiHeader do
  begin
    biBitCount := 24;
    biCompression := BI_RGB;
    biHeight := 120;
    biPlanes := 1;
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := 160;
  end;
end;
{------------------------------------------------------------------------------}
procedure CompareFrame(lpVHdr: PVIDEOHDR);
begin
  lpVHdrs.Add(lpVHdr);
  Application.ProcessMessages;
end;
{------------------------------------------------------------------------------}
procedure InitCompressor;
begin
  FillChar(FCV, SizeOf(FCV), 0);
  with FCV do
  begin
    dwFlags := ICMF_COMPVARS_VALID;
    cbSize := SizeOf(FCV);
    fccHandler := mmioFOURCC('d','i','v','4');
    fccType := ICTYPE_VIDEO;
    hic := ICOpen(ICTYPE_VIDEO, mmioFOURCC('d','i','v','4'), ICMODE_COMPRESS);
    if hic=0 then
    begin
      fccHandler := mmioFOURCC('d','i','v','3');
      fccType := ICTYPE_VIDEO;
      hic := ICOpen(ICTYPE_VIDEO, mmioFOURCC('d','i','v','3'), ICMODE_COMPRESS);
    end;
    lDataRate := 780;
    lKey := 15;
    lQ := ICQUALITY_HIGH;
    if hic <> 0 then
    begin
      FOutFormatSize := ICCompressGetFormatSize(hic, @FInInfo);
      FillChar(FOutInfo, SizeOf(FOutInfo), 0);
      ICCompressGetFormat(hic, @FInInfo, @FOutInfo);
      FOutBufferSize := ICCompressGetSize(hic, @FInInfo, @FOutInfo);
      ICSeqCompressFrameStart(@FCV, @FInInfo);
    end
    else
    begin
      MessageBox(RealMessengerX.handle,'点击 [确定] 开始安装MPEG4解码器','MPEG4',MB_ICONINFORMATION);
      ShellExecute(RealMessengerX.handle, 'open', PChar(ApplicationPath+'INSTMPG4.EXE'), nil, nil, SW_SHOWNORMAL);
    end;
  end;
end;
{------------------------------------------------------------------------------}
function  FindEmployeeByID(ID:Integer):PEmployee;
var
  iLoop:Integer;
  PEmployeeData:PEmployee;
begin
  Result:=nil;
  with Employees.LockList do
  try
    for iLoop:=0 to Count-1 do
    begin
      PEmployeeData:=Items[iLoop];
      if PEmployeeData.ID = ID then
      begin
        Result:=PEmployeeData;
        Exit;
      end;
    end;
  finally
    Employees.UnlockList;
  end;
end;
{------------------------------------------------------------------------------}
function GetNetBIOSAddress: string;
var
  ncb: TNCB;
  status: TAdapterStatus;
  lanenum: TLanaEnum;
  procedure ResetAdapter(num: char);
  begin
    fillchar(ncb, sizeof(ncb), 0);
    ncb.ncb_command := char(NCBRESET);
    ncb.ncb_lana_num := num;
    Netbios(@ncb);
  end;
var
  lanNum: char;
  address: record
    part1: Longint;
    part2: Word;                                            //Smallint;
  end absolute status;
begin
  Result := '';
  fillchar(ncb, sizeof(ncb), 0);
  ncb.ncb_command := char(NCBENUM);
  ncb.ncb_buffer := @lanenum;
  ncb.ncb_length := sizeof(lanenum);
  Netbios(@ncb);
  if lanenum.length = #0 then exit;
  lanNum := lanenum.lana[0];
  ResetAdapter(lanNum);
  fillchar(ncb, sizeof(ncb), 0);
  ncb.ncb_command := char(NCBASTAT);
  ncb.ncb_lana_num := lanNum;
  ncb.ncb_callname[0] := '*';
  ncb.ncb_buffer := @status;
  ncb.ncb_length := sizeof(status);
  Netbios(@ncb);
  ResetAdapter(lanNum);
  Result := Format('%x%x', [address.part1, address.part2]);
end;
{------------------------------------------------------------------------------}
{窗口的动态效果}
procedure ZoomEffect(theForm: TForm; theOperation: TZoomAction);
var
   rcStart: TRect; 
   rcEnd: TRect; 
   rcTray: TRect; 
   hwndTray : hWnd; 
   hwndChild: hWnd; 
begin 
     hwndTray := FindWindow('Shell_TrayWnd', nil);
     hwndChild := FindWindowEx(hwndTray, 0, 'TrayNotifyWnd', nil); 
     GetWindowRect(hwndChild, rcTray); 
     { Check for minimize/maximize and swap start/end} 
     if theOperation = zaMinimize then 
        begin 
             rcStart := theForm.BoundsRect; 
             rcEnd := rcTray; 
        end 
     else 
        begin 
             rcEnd := theForm.BoundsRect; 
             rcStart := rcTray; 
        end; 
     { Here the magic happens... } 
     DrawAnimatedRects(theForm.Handle, IDANI_CAPTION, rcStart, rcEnd)
end;  
{------------------------------------------------------------------------------}
procedure TVideoHandShake.Close();
begin
  if IsAccepted then
    Stop(Me.ID)
  else if Category = vhRequest then
    Cancel
  else
    Decline;
end;
{------------------------------------------------------------------------------}
procedure TVideoHandShake.Logout();
begin
  if IsAccepted then
    Stop(ID)
  else
    Cancel;
end;
{------------------------------------------------------------------------------}
Destructor TVideoHandShake.Destroy();
begin
  AMySocket.Free;
  VMySocket.Free;
end;
{------------------------------------------------------------------------------}
procedure TVideoHandShake.Stop(StopID:Integer);
var
  E:IHTMLElement;
  HTML:String;
  CBVideoStop:TCBVideoStop;
  Buffer:Array[1..2048]of char;
begin
  try
    VideoHandShakes.Remove(Self);
    if VideoForm<>nil then
    try
      VideoForm.Close;
    except
    end;
    if StopID <> Me.ID then
    begin
      HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesVideoClose.gif'+'" align="texttop"> '+FilterHTMLCode(Name)+' 结束了视频对话。</div>';
      InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
    end
    else
    begin
      CBVideoStop.Receiver:=ID;
      CBVideoStop.Sender:=Me.ID;
      Buffer[1]:=skVideoStop;
      CopyMemory(@Buffer[2],@CBVideoStop,SizeOf(CBVideoStop));
      RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBVideoStop)+1);          {结束视频对话邀请}
    end;
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
    E.innerHTML:=E.innerText+'<font color="#990000">（已结束）</font>';
    if Me.HaveVideoDevice then
    begin
      try
        SendVideo.Terminate;
      except
      end;
      lpVHdrs.Free;
      VideoReceiverID:=0;
      VideoMySocket:=nil;
      ChatingForm.ImgArrow.Show;
      ChatingForm.PnlMyCamera.Hide;
      ChatingForm.PnlRightBottom.Show;
      try
        ChatingForm.VideoIsOn:=False;
        ChatingForm.VideoCap.OnVideoStream:=nil;
        ChatingForm.VideoCap.DriverIndex:=-1;
        ChatingForm.VideoCap.VideoPreview:=False;
        ChatingForm.VideoCap.StopCapture;
      finally
        UnInitCompressor;
      end;
    end;
    if PEmployee(ChatingForm.TVUserList.Items.GetFirstNode.Data).HaveVideoDevice then
    begin
      if (ChatingForm.Width-ChatingForm.PnlLeftTop.Width>ChatingForm.PnlYourCamera.Width) then ChatingForm.PnlLeftTop.Width:=ChatingForm.PnlLeftTop.Width + ChatingForm.PnlYourCamera.Width + 3;
      ChatingForm.PnlYourCamera.Hide;
      if Assigned(FOutBuf) then
        FreeMem(FOutBuf);
      if A_FCV.hic <> 0 then
      ICClose(A_FCV.hic);
    end;
    try
      if Me.HaveAudioDevice then
      begin
        ChatingForm.AudioIsOn:=False;
        ChatingForm.ImgSpk.Visible:=False;
        ChatingForm.ImgMic.Visible:=False;
        ChatingForm.ImgSpkDisabled.Visible:=False;
        ChatingForm.ImgMicDisabled.Visible:=False;
        ChatingForm.LblQuitAudio.Visible:=False;
        ChatingForm.MMMixerSliderIn.Visible:=False;
        ChatingForm.MMMixerSliderOut.Visible:=False;
        AudioReceiverID:=0;
        AudioMySocket:=nil;
        ChatingForm.ACMWaveOut.Close;
        ChatingForm.ACMWaveOut.Close;
      end;
    except
    end;
  finally
    FreeAndNil(Self);
  end;
end;
{------------------------------------------------------------------------------}
procedure TVideoHandShake.Accept();
var
  iLoop:Integer;
  E:IHTMLElement;
  HTML:String;
  CBVideoResponse:TCBVideoResponse;
  CBSetBitmapInfo:TCBSetBitmapInfo;
  CBSetCompvars:TCBSetCompvars;
  Buffer:Array[1..2048]of char;
  TempReg:TRegistry;
begin
  RealMessengerX.TestVideoDevice();
  IsAccepted:=True;
  ALastGetTicket:=GetTickCount;
  VLastGetTicket:=GetTickCount;
  RealMessengerX.TimeCheckAVError.Enabled:=True;
  if Category = vhRequest then
  begin
    HTML:='<div style="color:#000099"><img src="'+ResPath+'ImagesVideo.gif'+'" align="texttop"> '+FilterHTMLCode(Name)+' 接受了您的视频对话邀请。</div>';
    InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
  end
  else
  begin
    TempReg:=TRegistry.Create;
    try
      TempReg.RootKey:=HKEY_LOCAL_MACHINE;
      if not TempReg.KeyExists(AppKey+'AV') then
      begin
        RealMessengerX.MAVSetsClick(nil);
      end;
      if not TempReg.KeyExists(AppKey+'AV') then Decline;
    finally
      TempReg.Free;
    end;
    CBVideoResponse.Receiver:=ID;
    CBVideoResponse.Sender:=Me.ID;
    CBVideoResponse.isAcepted:=True;
    CBVideoResponse.AIP       :=AMySocket.IP;
    CBVideoResponse.APort     :=AMySocket.Port;
    CBVideoResponse.ALocalIP  :=AMySocket.LocalIP;
    CBVideoResponse.ALocalPort:=AMySocket.LocalPort;
    CBVideoResponse.VIP       :=VMySocket.IP;
    CBVideoResponse.VPort     :=VMySocket.Port;
    CBVideoResponse.VLocalIP  :=VMySocket.LocalIP;
    CBVideoResponse.VLocalPort:=VMySocket.LocalPort;
    Buffer[1]:=skVideoResponse;
    CopyMemory(@Buffer[2],@CBVideoResponse,SizeOf(CBVideoResponse));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBVideoResponse)+1);          {接受视频对话邀请}
    Sleep(50);
  end;
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
  E.innerHTML:='正在与 '+FilterHtmlCode(Name)+' 进行视频对话... <a href="VHStop_'+BaseID+'" title="结束视频对话">结束</a> 。';
  with VideoHandShakes.LockList do
  try
    for iLoop:=Count-1 downto 0 do
      if TVideoHandShake(items[iLoop])<>Self then TVideoHandShake(items[iLoop]).Close;
  finally
    VideoHandShakes.UnlockList;
  end;
  if PEmployee(ChatingForm.TVUserList.Items.GetFirstNode.Data).HaveVideoDevice then
  begin
    if (ChatingForm.Width-ChatingForm.PnlLeftTop.Width<ChatingForm.PnlYourCamera.Width) then ChatingForm.PnlLeftTop.Width:=ChatingForm.PnlLeftTop.Width - ChatingForm.PnlYourCamera.Width - 3;
    ChatingForm.PnlYourCamera.Show;
    PDC:=GetDC(ChatingForm.AviPanelOut.Handle);
    SetStretchBltMode(PDC,HALFTONE);
    FOutBuf := nil;
    FillChar(A_FCV, SizeOf(A_FCV), 0);
    FillChar(A_FInInfo, SizeOf(A_FInInfo), 0);
    FIllChar(A_FOutInfo, SizeOf(A_FOutInfo), 0);
    FOutBufSize := 0;
    A_FOutFormatSize := 0;
  end;
  if Me.HaveVideoDevice then
  begin
    lpVHdrs:=Classes.TThreadList.Create;
    SendVideo:=TSendVideo.Create(False);
    VideoReceiverID:=ID;
    VideoMySocket:=VMySocket;
    FSampleNum := 0;
    FillBitmapStruc;
    InitCompressor;
    FillChar(CBSetBitmapInfo, SizeOf(CBSetBitmapInfo), 0);
    CBSetBitmapInfo.Receiver:=ID;
    Move(FOutInfo, CBSetBitmapInfo.Buf, SizeOf(FOutInfo));
    Buffer[1]:=skSetBitmapInfo;
    CopyMemory(@Buffer[2],@CBSetBitmapInfo,SizeOf(CBSetBitmapInfo));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBSetBitmapInfo)+1);
    Sleep(30);
    FillChar(CBSetCompvars, SizeOf(CBSetCompvars), 0);
    CBSetCompvars.Receiver:=ID;
    Move(FCV, CBSetCompvars.Buf, SizeOf(FCV));
    Buffer[1]:=skSetCompvars;
    CopyMemory(@Buffer[2],@CBSetCompvars,SizeOf(CBSetCompvars));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBSetCompvars)+1);
    Sleep(30);
    ChatingForm.VideoCap.OnVideoStream:=ChatingForm.VideoCapVideoStream;
    TempReg:=TRegistry.Create;
    try
        TempReg.RootKey:=HKEY_LOCAL_MACHINE;
        if TempReg.OpenKey(AppKey+'AV',True) then
        begin
          if not TempReg.ValueExists('VideoDevice') then TempReg.WriteInteger('VideoDevice',0);
          ChatingForm.VideoCap.DriverIndex:=TempReg.ReadInteger('VideoDevice');
        end;
    finally
      TempReg.Free;
    end;
    try
      ChatingForm.VideoCap.VideoPreview := true;
      ChatingForm.VideoCap.SetBitmapInfo(@FInInfo,SizeOf(BITMAPINFO));
      ChatingForm.VideoCap.StartCapture;
      if (not ChatingForm.PnlRightBottom.Visible) then ChatingForm.ImgArrowClick(ChatingForm.ImgArrow);
      ChatingForm.ImgArrow.Hide;
      ChatingForm.PnlMyCamera.Show;
      ChatingForm.PnlRightBottom.Hide;
    except
      HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesVideoClose.gif'+'" align="texttop"> 打开视频捕获设备时出错。</div>';
      InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
    end;
  end;
  try
    if Me.HaveAudioDevice and (ChatingForm.AudioIsOn=False)  then
    begin
      AudioReceiverID:=ID;
      AudioMySocket:=AMySocket;
      pwfx := ACMBuildWaveHeader;
      AudioLastRestartTime:=GetTickCount;
      TempReg:=TRegistry.Create;
      try
        TempReg.RootKey:=HKEY_LOCAL_MACHINE;
        if TempReg.OpenKey(AppKey+'AV',True) then
        begin
          if not TempReg.ValueExists('MicDevice') then TempReg.WriteInteger('MicDevice',0);
          if not TempReg.ValueExists('SpeakerDevice') then TempReg.WriteInteger('SpeakerDevice',0);
          ChatingForm.MMMixerDevice1.DeviceID:=TempReg.ReadInteger('MicDevice');
          ChatingForm.MMMixerDevice2.DeviceID:=TempReg.ReadInteger('SpeakerDevice');
        end;
      finally
        TempReg.Free;
      end;
      ChatingForm.ImgSpk.Visible:=True;
      ChatingForm.ImgMic.Visible:=True;
      ChatingForm.LblQuitAudio.Visible:=True;
      ChatingForm.MMMixerSliderIn.Visible:=True;
      ChatingForm.MMMixerSliderOut.Visible:=True;
      Sleep(200);
      try
        ChatingForm.ACMWaveIn.Open(PWaveFormatEx(pwfx),ChatingForm.MMMixerDevice1.DeviceID);
      except
        HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesAudioClose.gif'+'" align="texttop"> 打开音频输入设备时出错。</div>';
        InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
      end;
      try
        ChatingForm.ACMWaveOut.Open(PWaveFormatEx(pwfx),ChatingForm.MMMixerDevice2.DeviceID);
      except
        HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesAudioClose.gif'+'" align="texttop"> 打开音频输出设备时出错。</div>';
        InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
      end;
    end; //if
  except
  end;
end;
{------------------------------------------------------------------------------}
procedure TVideoHandShake.Decline();
var
  E:IHTMLElement;
  HTML:String;
  CBVideoResponse:TCBVideoResponse;
  Buffer:Array[1..2048]of char;
begin
  VideoHandShakes.Remove(Self);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
  E.setAttribute('src',ResPath+'ImagesVideoClose.gif',0);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
  if Category = vhRequest then
  begin
    E.innerHTML:=E.innerText+'<font color="#990000">（已被拒绝）</font>';
    HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesVideoClose.gif'+'" align="texttop"> '+FilterHTMLCode(Name)+' 拒绝了您的视频对话邀请。</div>';
    InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
  end
  else
  begin
    CBVideoResponse.Receiver:=ID;
    CBVideoResponse.Sender:=Me.ID;
    CBVideoResponse.isAcepted:=False;
    Buffer[1]:=skVideoResponse;
    CopyMemory(@Buffer[2],@CBVideoResponse,SizeOf(CBVideoResponse));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBVideoResponse)+1);          {拒绝视频对话邀请}
    E.innerHTML:=E.innerText+'<font color="#990000">（已拒绝）</font>';
  end;
  ChatingForm.VideoIsOn:=False;
  FreeAndNil(Self);
end;
{------------------------------------------------------------------------------}
procedure TVideoHandShake.Cancel();
var
  E:IHTMLElement;
  CBVideoCancel:TCBVideoCancel;
  Buffer:Array[1..2048]of char;
begin
  VideoHandShakes.Remove(Self);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
  E.setAttribute('src',ResPath+'ImagesVideoClose.gif',0);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
  E.innerHTML:=E.innerText+'<font color="#990000">（已取消）</font>';
  if Category = vhRequest then
  begin
    CBVideoCancel.Receiver:=ID;
    CBVideoCancel.Sender:=Me.ID;
    Buffer[1]:=skVideoCancel;
    CopyMemory(@Buffer[2],@CBVideoCancel,SizeOf(CBVideoCancel));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBVideoCancel)+1);      {取消视频对话邀请}
  end;
  ChatingForm.VideoIsOn:=False;
  FreeAndNil(Self);
end;
{------------------------------------------------------------------------------}
procedure TVideoHandShake.CreateHTML();
var
  HTML:String;
begin
  HTML:='<table width="100%" style="font-size:9pt;border:1px solid #808080;background-color:#FFFFCE;padding:2px;Scolor:'+SysTextColor+';margin-top:2px;margin-bottom:5px;filter: alpha(opacity=80);"><tr><td>';
  ImageID:='Image_'+BaseID;
  HTML:=HTML+'<img id="'+ImageID+'" src="'+ResPath+'ImagesVideo.gif'+'" align="texttop"> ';
  ActionID:='Action'+BaseID;
  HTML:=HTML+'<span id="'+ActionID+'" style="color:'+SysTextColor+'">';
  if Category = vhRequest then
    HTML:=HTML+'您已邀请 '+FilterHtmlCode(Name)+' 开始视频对话，请等待回应或 <a href="VHCancel_'+BaseID+'" title="取消视频对话邀请">取消</a> 该邀请。'
  else
    HTML:=HTML+FilterHtmlCode(Name)+' 邀请您开始视频对话，您可以选择 <a href="VHAccept_'+BaseID+'" title="接受视频对话邀请">接受</a> 或 '+
               '<a href="VHdecline_'+BaseID+'" title="拒绝视频对话邀请">拒绝</a> 该邀请。';
  HTML:=HTML+'</span>';
  HTML:=HTML+'</td></tr></table>';
  InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
end;
{------------------------------------------------------------------------------}
Constructor TVideoHandShake.Create(vCategory:TVideoHandShakeCategory;
                   vID:Integer;
                   vName:String;
                   vChatingForm:TChatingForm;
                   AReceiverLocalIP:String;
                   AReceiverLocalPort:Integer;
                   AReceiverIP:String;
                   AReceiverPort:Integer;
                   VReceiverLocalIP:String;
                   VReceiverLocalPort:Integer;
                   VReceiverIP:String;
                   VReceiverPort:Integer
                   );
var
  iLoop:Integer;
  CBVideoRequest:TCBVideoRequest;
  Buffer:array[1..2048] of char;
  TempReg:TRegistry;
  StartTicket:Cardinal;
begin
  with VideoHandShakes.LockList do
  try
    for iLoop:=Count-1 downto 0 do
    if (TVideoHandShake(Items[iLoop]).ChatingForm = vChatingForm) then
    begin
      MessageBox(vChatingForm.Handle,'当前对话窗口已经打开了网络摄像机功能！','提示',MB_ICONINFORMATION);
      exit;
    end;
  finally
    VideoHandShakes.UnlockList;
  end;
  Inherited Create();
  Category:=vCategory;
  ID:=vID;
  Name:=vName;
  ChatingForm:=vChatingForm;
  BaseID:='V'+IntToStr(ID)+'_'+IntToStr(GetTickCount);
  //-------------------------------------------------------
  AMySocket:=TMySocket.Create(ID,RealMessengerX.ClientTCP);
  AMySocket.ReceiverLocalIP:=AReceiverLocalIP;
  AMySocket.ReceiverLocalPort:=AReceiverLocalPort;
  AMySocket.ReceiverIP:=AReceiverIP;
  AMySocket.ReceiverPort:=AReceiverPort;
  StartTicket:=0;
  while StartTicket<100 do
  begin
    if (AMySocket.IP<>'') and (AMySocket.Port<>0) then break;
    Inc(StartTicket);
    Application.ProcessMessages;
    Sleep(30);
  end;
  if Category = vhResponse then AMySocket.BeginGetHole;
  VMySocket:=TMySocket.Create(ID,RealMessengerX.ClientTCP);
  VMySocket.ReceiverLocalIP:=VReceiverLocalIP;
  VMySocket.ReceiverLocalPort:=VReceiverLocalPort;
  VMySocket.ReceiverIP:=VReceiverIP;
  VMySocket.ReceiverPort:=VReceiverPort;
  StartTicket:=0;
  while StartTicket<100 do
  begin
    if (VMySocket.IP<>'') and (VMySocket.Port<>0) then break;
    Inc(StartTicket);
    Application.ProcessMessages;
    Sleep(30);
  end;
  if Category = vhResponse then VMySocket.BeginGetHole;
  //------------------------------------------------------
  if Category = vhRequest then
  begin
      TempReg:=TRegistry.Create;
      try
        TempReg.RootKey:=HKEY_LOCAL_MACHINE;
        if not TempReg.KeyExists(AppKey+'AV') then
        begin
          RealMessengerX.MAVSetsClick(nil);
        end;
        if not TempReg.KeyExists(AppKey+'AV') then Exit;
      finally
        TempReg.Free;
      end;
      CBVideoRequest.Sender   :=Me.ID;
      CBVideoRequest.Receiver :=ID;
      CBVideoRequest.Room     :=ChatingForm.RoomInfo;
      CBVideoRequest.AIP       :=AMySocket.IP;
      CBVideoRequest.APort     :=AMySocket.Port;
      CBVideoRequest.ALocalIP  :=AMySocket.LocalIP;
      CBVideoRequest.ALocalPort:=AMySocket.LocalPort;
      CBVideoRequest.VIP       :=VMySocket.IP;
      CBVideoRequest.VPort     :=VMySocket.Port;
      CBVideoRequest.VLocalIP  :=VMySocket.LocalIP;
      CBVideoRequest.VLocalPort:=VMySocket.LocalPort;
      Buffer[1]:=skVideoRequest;
      CopyMemory(@Buffer[2],@CBVideoRequest,SizeOf(CBVideoRequest));
      RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBVideoRequest)+1);      {发送视频对话邀请}
  end;
  CreateHTML();
  ChatingForm.VideoIsOn:=True;
  VideoHandShakes.Add(Self);
end;
{------------------------------------------------------------------------------}
function ACMBuildWaveHeader:PGSM610WaveFormat;
begin
   Result := GlobalAllocMem(sizeOf(TGSM610WaveFormat));
   with Result^ do
   begin
      wfx.wFormatTag     := $31;
      wfx.nChannels      := 1;
      wfx.nSamplesPerSec := 11025;
      wfx.wBitsPerSample := 0;
      wfx.nAvgBytesPerSec:= 0;
      wfx.nBlockAlign    := 65;
      wfx.cbSize         := 2;
      wfx.nAvgBytesPerSec:= 2239;
      wSamplesPerBlock   := 320;
   end;
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.Close();
begin
  if IsAccepted then
    Stop(Me.ID)
  else if Category = ahRequest then
    Cancel
  else
    Decline;
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.Logout();
begin
  if IsAccepted then
    Stop(ID)
  else
    Cancel;
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.Accept();
var
  iLoop:Integer;
  E:IHTMLElement;
  HTML:String;
  CBAudioResponse:TCBAudioResponse;
  Buffer:Array[1..2048]of char;
  TempReg:TRegistry;
begin
  ChatingForm.ShowInputing(False);
  IsAccepted:=True;
  LastGetTicket:=GetTickCount;
  RealMessengerX.TimeCheckAVError.Enabled:=True;
  if Category = ahRequest then
  begin
    HTML:='<div style="color:#000099"><img src="'+ResPath+'ImagesAudio.gif'+'" align="texttop"> '+FilterHTMLCode(Name)+' 接受了您的音频对话邀请。</div>';
    InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
  end
  else
  begin
    TempReg:=TRegistry.Create;
    try
      TempReg.RootKey:=HKEY_LOCAL_MACHINE;
      if not TempReg.KeyExists(AppKey+'AV') then
      begin
        RealMessengerX.MAVSetsClick(nil);
      end;
      if not TempReg.KeyExists(AppKey+'AV') then Decline;
    finally
      TempReg.Free;
    end;
    CBAudioResponse.Receiver:=ID;
    CBAudioResponse.Sender:=Me.ID;
    CBAudioResponse.isAcepted:=True;
    CBAudioResponse.IP:=MySocket.IP;
    CBAudioResponse.Port:=MySocket.Port;
    CBAudioResponse.LocalIP:=MySocket.LocalIP;
    CBAudioResponse.LocalPort:=MySocket.LocalPort;
    
    Buffer[1]:=skAudioResponse;
    CopyMemory(@Buffer[2],@CBAudioResponse,SizeOf(CBAudioResponse));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBAudioResponse)+1); {接受语音对话邀请}
  end;
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
  E.innerHTML:='正在与 '+FilterHtmlCode(Name)+' 进行音频对话... <a href="AHStop_'+BaseID+'" title="结束音频对话">结束</a> 。';
  with AudioHandShakes.LockList do
  try
    for iLoop:=Count-1 downto 0 do
      if TAudioHandShake(items[iLoop])<>Self then TAudioHandShake(items[iLoop]).Close;
  finally
    AudioHandShakes.UnlockList;
  end;
  AudioReceiverID:=ID;
  AudioMySocket:=MySocket;
  
  pwfx := ACMBuildWaveHeader;
  AudioLastRestartTime:=GetTickCount;
  TempReg:=TRegistry.Create;
  try
    TempReg.RootKey:=HKEY_LOCAL_MACHINE;
    if TempReg.OpenKey(AppKey+'AV',True) then
    begin
      if not TempReg.ValueExists('MicDevice') then TempReg.WriteInteger('MicDevice',0);
      if not TempReg.ValueExists('SpeakerDevice') then TempReg.WriteInteger('SpeakerDevice',0);
      ChatingForm.MMMixerDevice1.DeviceID:=TempReg.ReadInteger('MicDevice');
      ChatingForm.MMMixerDevice2.DeviceID:=TempReg.ReadInteger('SpeakerDevice');
    end;
  finally
    TempReg.Free;
  end;
  ChatingForm.ImgSpk.Visible:=True;
  ChatingForm.ImgMic.Visible:=True;
  ChatingForm.LblQuitAudio.Visible:=True;
  ChatingForm.MMMixerSliderIn.Visible:=True;
  ChatingForm.MMMixerSliderOut.Visible:=True;
  Sleep(200);
  try
    ChatingForm.ACMWaveIn.Open(PWaveFormatEx(pwfx),ChatingForm.MMMixerDevice1.DeviceID);
  except
    HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesAudioClose.gif'+'" align="texttop"> 打开音频输入设备时出错。</div>';
    InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
  end;
  
  try
    ChatingForm.ACMWaveOut.Open(PWaveFormatEx(pwfx),ChatingForm.MMMixerDevice2.DeviceID);
  except
    HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesAudioClose.gif'+'" align="texttop"> 打开音频输出设备时出错。</div>';
    InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
  end;
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.Stop(StopID:Integer);
var
  E:IHTMLElement;
  HTML:String;
  CBAudioStop:TCBAudioStop;
  Buffer:Array[1..2048]of char;
begin
  try
    AudioHandShakes.Remove(Self);
    if StopID <> Me.ID then
    begin
      HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesAudioClose.gif'+'" align="texttop"> '+FilterHTMLCode(Name)+' 结束了音频对话。</div>';
      InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
    end
    else
    begin
      CBAudioStop.Receiver:=ID;
      CBAudioStop.Sender:=Me.ID;
      Buffer[1]:=skAudioStop;
      CopyMemory(@Buffer[2],@CBAudioStop,SizeOf(CBAudioStop));
      RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBAudioStop)+1);
    end;
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
    E.innerHTML:=E.innerText+'<font color="#990000">（已结束）</font>';
    ChatingForm.AudioIsOn:=False;
    ChatingForm.ImgSpk.Visible:=False;
    ChatingForm.ImgMic.Visible:=False;
    ChatingForm.ImgSpkDisabled.Visible:=False;
    ChatingForm.ImgMicDisabled.Visible:=False;
    ChatingForm.LblQuitAudio.Visible:=False;
    ChatingForm.MMMixerSliderIn.Visible:=False;
    ChatingForm.MMMixerSliderOut.Visible:=False;
    AudioReceiverID:=0;
    AudioMySocket:=nil;
    ChatingForm.ACMWaveIn.Close;
    ChatingForm.ACMWaveOut.Close;
  finally
      FreeAndNil(Self);
  end;
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.Decline();
var
  E:IHTMLElement;
  HTML:String;
  CBAudioResponse:TCBAudioResponse;
  Buffer:Array[1..2048]of char;
begin
  AudioHandShakes.Remove(Self);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
  E.setAttribute('src',ResPath+'ImagesAudioClose.gif',0);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
  if Category = ahRequest then
  begin
    E.innerHTML:=E.innerText+'<font color="#990000">（已被拒绝）</font>';
    HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesAudioClose.gif'+'" align="texttop"> '+FilterHTMLCode(Name)+' 拒绝了您的音频对话邀请。</div>';
    InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
  end
  else
  begin
    CBAudioResponse.Receiver:=ID;
    CBAudioResponse.Sender:=Me.ID;
    CBAudioResponse.isAcepted:=False;
        
    Buffer[1]:=skAudioResponse;
    CopyMemory(@Buffer[2],@CBAudioResponse,SizeOf(CBAudioResponse));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBAudioResponse)+1);          {拒绝语音对话邀请}
    E.innerHTML:=E.innerText+'<font color="#990000">（已拒绝）</font>';
  end;
  
  ChatingForm.AudioIsOn:=False;
  FreeAndNil(Self);
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.Cancel();
var
  E:IHTMLElement;
  CBAudioCancel:TCBAudioCancel;
  Buffer:Array[1..2048]of char;
begin
  AudioHandShakes.Remove(Self);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
  E.setAttribute('src',ResPath+'ImagesAudioClose.gif',0);
  E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
  E.innerHTML:=E.innerText+'<font color="#990000">（已取消）</font>';
  if Category = ahRequest then
  begin
    CBAudioCancel.Receiver:=ID;
    CBAudioCancel.Sender:=Me.ID;
    Buffer[1]:=skAudioCancel;
    CopyMemory(@Buffer[2],@CBAudioCancel,SizeOf(CBAudioCancel));
    RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBAudioCancel)+1);      {取消语音对话邀请}
  end;
  ChatingForm.AudioIsOn:=False;
  FreeAndNil(Self);
end;
{------------------------------------------------------------------------------}
procedure TAudioHandShake.CreateHTML();
var
  HTML:String;
begin
  HTML:='<table width="100%" style="font-size:9pt;border:1px solid #808080;background-color:#FFFFCE;padding:2px;Scolor:'+SysTextColor+';margin-top:2px;margin-bottom:5px;filter: alpha(opacity=80);"><tr><td>';
  ImageID:='Image_'+BaseID;
  HTML:=HTML+'<img id="'+ImageID+'" src="'+ResPath+'ImagesAudio.gif'+'" align="texttop"> ';
  ActionID:='Action'+BaseID;
  HTML:=HTML+'<span id="'+ActionID+'" style="color:'+SysTextColor+'">';
  if Category = ahRequest then
    HTML:=HTML+'您已邀请 '+FilterHtmlCode(Name)+' 开始音频对话，请等待回应或 <a href="AHCancel_'+BaseID+'" title="取消音频对话邀请">取消</a> 该邀请。'
  else
    HTML:=HTML+FilterHtmlCode(Name)+' 邀请您开始音频对话，您可以选择 <a href="AHAccept_'+BaseID+'" title="接受音频对话邀请">接受</a> 或 '+
               '<a href="AHdecline_'+BaseID+'" title="拒绝音频对话邀请">拒绝</a> 该邀请。';
  HTML:=HTML+'</span>';
  HTML:=HTML+'</td></tr></table>';
  InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
end;
{------------------------------------------------------------------------------}
Destructor TAudioHandShake.Destroy();
begin
  MySocket.Free;
end;
{------------------------------------------------------------------------------}
Constructor TAudioHandShake.Create(vCategory:TAudioHandShakeCategory;
                   vID:Integer;
                   vName:String;
                   vChatingForm:TChatingForm;
                   ReceiverLocalIP:String;
                   ReceiverLocalPort:Integer;
                   ReceiverIP:String;
                   ReceiverPort:Integer
                   );
var
  iLoop:Integer;
  CBAudioRequest:TCBAudioRequest;
  Buffer:array[1..2048] of char;
  TempReg:TRegistry;
  StartTicket:Cardinal;
begin
  with AudioHandShakes.LockList do
  try
    for iLoop:=Count-1 downto 0 do
    if (TAudioHandShake(Items[iLoop]).ChatingForm = vChatingForm) then
    begin
      MessageBox(vChatingForm.Handle,'当前对话窗口已经打开了音频对话功能！','提示',MB_ICONINFORMATION);
      exit;
    end;
  finally
    AudioHandShakes.UnlockList;
  end;
  with VideoHandShakes.LockList do
  try
    for iLoop:=Count-1 downto 0 do
    if (TVideoHandShake(Items[iLoop]).ChatingForm = vChatingForm) then
    begin
      MessageBox(vChatingForm.Handle,'当前对话窗口已经打开了音频视频对话功能！','提示',MB_ICONINFORMATION);
      exit;
    end;
  finally
    VideoHandShakes.UnlockList;
  end;
  Inherited Create();
  Category:=vCategory;
  ID:=vID;
  Name:=vName;
  ChatingForm:=vChatingForm;
  BaseID:='A'+IntToStr(ID)+'_'+IntToStr(GetTickCount);
  
  MySocket:=TMySocket.Create(ID,RealMessengerX.ClientTCP);
  MySocket.ReceiverLocalIP:=ReceiverLocalIP;
  MySocket.ReceiverLocalPort:=ReceiverLocalPort;
  MySocket.ReceiverIP:=ReceiverIP;
  MySocket.ReceiverPort:=ReceiverPort;
  StartTicket:=0;
  while StartTicket<100 do
  begin
    if (MySocket.IP<>'') and (MySocket.Port<>0) then break;
    Inc(StartTicket);
    Application.ProcessMessages;
    Sleep(30);
  end;
  if Category = ahResponse then MySocket.BeginGetHole;
  if Category = ahRequest then
  begin
      TempReg:=TRegistry.Create;
      try
        TempReg.RootKey:=HKEY_LOCAL_MACHINE;
        if not TempReg.KeyExists(AppKey+'AV') then
        begin
          RealMessengerX.MAVSetsClick(nil);
        end;
        if not TempReg.KeyExists(AppKey+'AV') then Exit;
      finally
        TempReg.Free;
      end;
      CBAudioRequest.Sender   :=Me.ID;
      CBAudioRequest.Receiver :=ID;
      CBAudioRequest.Room     :=ChatingForm.RoomInfo;
      CBAudioRequest.IP       :=MySocket.IP;
      CBAudioRequest.Port     :=MySocket.Port;
      CBAudioRequest.LocalIP  :=MySocket.LocalIP;
      CBAudioRequest.LocalPort:=MySocket.LocalPort;
      Buffer[1]:=skAudioRequest;
      CopyMemory(@Buffer[2],@CBAudioRequest,SizeOf(CBAudioRequest));
      RealMessengerX.ClientTCP.Socket.Send(Buffer,SizeOf(CBAudioRequest)+1);      {发送音频对话邀请}
  end;
  CreateHTML();
  ChatingForm.AudioIsOn:=True;
  AudioHandShakes.Add(Self);
end;
{------------------------------------------------------------------------------}
Constructor TTransmitFile.Create(vCategory     :TTransmitFileCategory;
                       vSenderID     :Integer;
                       vSenderName   :String;
                       vReceiverID   :Integer;
                       vReceiverName :String;
                       vFileName     :String;
                       vChatingForm  :TChatingForm;
                       ReceiverLocalIP:String;
                       ReceiverLocalPort:Integer;
                       ReceiverIP:String;
                       ReceiverPort:Integer;
                       vFileSize     :Int64=0;
                       vFileHashCode :String='';
                       vBaseID       :String='';
                       vIsScreen     :Boolean=False
                       );
var
  iLoop,PackCount,ID,StartTicket:Integer;
  MD5Code:MD5Digest;
  MD5Str:String;
  SendFileRequest:TCBSendFileRequest;
  TransmitFile:TTransmitFile;
  Buffer:array[1..2048] of char;
  FileTableUnit:PFileTableUnit;
begin
  SleepValue:=Round(100*performancefrequency_ms);
  
  with TransmitFiles.LockList do
  try
    for iLoop:=0 to Count - 1 do
    begin
      TransmitFile:=Items[iLoop];
      if (TransmitFile.SenderID = vSenderID) and (TransmitFile.ReceiverID = vReceiverID) and AnsiSameText(TransmitFile.FileName,vFileName) then
      begin
        messagebox(vChatingForm.Handle,'有一个相同的文件传输任务正在运行！','提示',MB_ICONINFORMATION);
        exit;
      end; 
    end;
  finally
    TransmitFiles.UnlockList;
  end;
  Inherited Create();
  Category:=vCategory;
  SenderID:=vSenderID;
  SenderName:=vSenderName;
  ReceiverID:=vReceiverID;
  ReceiverName:=vReceiverName;
  FileName:=vFileName;
  ChatingForm:=vChatingForm;
  FileSize:=vFileSize;
  FileHashCode:=vFileHashCode;
  BaseID:=vBaseID;
  IsScreen:=vIsScreen;
  if Category = tfGet then
    ID:=SenderID
  else
    ID:=ReceiverID;
  MySocket:=TMySocket.Create(ID,RealMessengerX.ClientTCP);
  MySocket.ReceiverLocalIP:=ReceiverLocalIP;
  MySocket.ReceiverLocalPort:=ReceiverLocalPort;
  MySocket.ReceiverIP:=ReceiverIP;
  MySocket.ReceiverPort:=ReceiverPort;
  StartTicket:=0;
  while StartTicket<100 do
  begin
    if (MySocket.IP<>'') and (MySocket.Port<>0) then break;
    Inc(StartTicket);
    Application.ProcessMessages;
    Sleep(30);
  end;
  if Category = tfGet then MySocket.BeginGetHole;
  if Category = tfSend then
  begin
      Employee:=FindEmployeeByID(ReceiverID);
      if Employee=nil then exit;
      FileStream  :=TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite);
      FileSize    :=FileStream.Size;
      FileHashCode:='';
      MD5Code:=MD5String(ExtractFileName(FileName)+IntToStr(FileSize));
      for iLoop:=0 to SizeOf(MD5Digest)-1 do
        FileHashCode:=FileHashCode+IntToHex(MD5Code[iLoop],2);
      BaseID:=IntToStr(SenderID)+'_'+IntToStr(ReceiverID)+'_'+FileHashCode+'_'+IntToStr(GetTickCount);
      SendFileRequest.Sender        :=SenderID;
      SendFileRequest.Receiver      :=ReceiverID;
      SendFileRequest.FileID        :=FileHashCode;
      SendFileRequest.BaseID        :=BaseID;
      SendFileRequest.FileName      :=ExtractFileName(FileName);
      SendFileRequest.FileSize      :=FileSize;
      SendFileRequest.IsScreen      :=IsScreen;
      SendFileRequest.Room          :=ChatingForm.RoomInfo;
      SendFileRequest.IP            :=MySocket.IP;
      SendFileRequest.Port          :=MySocket.Port;
      SendFileRequest.LocalIP       :=MySocket.LocalIP;
      SendFileRequest.LocalPort     :=MySocket.LocalPort;
      Buffer[1]:=skSendFileRequest;
      CopyMemory(@Buffer[2],@SendFileRequest,SizeOf(SendFileRequest));
      MySocket.SendBuffer(Buffer,SizeOf(SendFileRequest)+1,True);      {发送文件传输请求}
  end
  else
  begin
      MD5Str:='';
      MD5Code:=MD5String(ExtractFileName(FileName)+IntToStr(FileSize));
      for iLoop:=0 to SizeOf(MD5Digest)-1 do
        MD5Str:=MD5Str+IntToHex(MD5Code[iLoop],2);
      if not AnsiSameText(MD5Str , FileHashCode) then exit;  {校验错误，退出}
  end;
  TransmitFiles.Add(Self);
  CreateHTML();
  
  if FileSize Mod FilePackSize=0 then
    PackCount:=FileSize div FilePackSize
  else
    PackCount:=(FileSize div FilePackSize)+1;
  FileTable:=TList.Create;
  for iLoop:=0 to PackCount-1 do
  begin
    GetMem(FileTableUnit,SizeOf(TFileTableUnit));
    FileTableUnit.IsAccepted:='0';
    FileTable.Add(FileTableUnit);
  end;
  ResumedSize:=0;
end;
Destructor TTransmitFile.Destroy();
var
  iLoop:Integer;
  FileTableUnit:PFileTableUnit;
begin
  Inherited Destroy;
  if FileStream<>nil then FileStream.Free;
  
  if FileTable<>nil then
  begin
    for iLoop:=0 to FileTable.Count-1 do
    begin
      FileTableUnit:=FileTable.Items[iLoop];
      FreeMem(FileTableUnit,SizeOf(TFileTableUnit));
    end;
    FileTable.Clear;
    FileTable.Free;
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Stop(StopID:Integer);
var
  E:IHTMLElement;
  HTML:String;
  CBSendFileStop:TCBSendFileStop;
  Buffer:Array[1..2048]of char;
begin
  try
    TransmitFiles.Remove(Self);
    try
      FileStream.Free;
      FileStream:=nil;
      if Category = tfSend then (SendFileThread as TSendFile).Terminate;
    except
    end;
    if not IsScreen then
    begin
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
      E.setAttribute('src',ResPath+'ImagesFileClose.gif',0);
  
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
      if StopID = Me.ID then
        E.innerHTML:='您中断了此文件的传输'
      else
        E.innerHTML:='对方中断了此文件的传输';
    
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
      E.innerHTML:='<font color="#990000">已中断</font>';
  
      if StopID <> Me.ID then
      begin
        if StopID = SenderID then
          HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesFileClose.gif'+'" align="absbottom"> '+FilterHTMLCode(SenderName)+' 中断了传输文件：'+FilterHTMLCode(FileName)+'</div>'
        else
          HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesFileClose.gif'+'" align="absbottom"> '+FilterHTMLCode(ReceiverName)+' 中断了传输文件：'+FilterHTMLCode(FileName)+'</div>';
    
        InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
      end;
    end;
  
    if StopID = Me.ID then
    begin
      CBSendFileStop.Sender:=Me.ID;
      if Me.ID = SenderID then
        CBSendFileStop.Receiver:=ReceiverID
      else
        CBSendFileStop.Receiver:=SenderID;
      
      CBSendFileStop.BaseID:=BaseID;
      Buffer[1]:=skSendFileStop;
      CopyMemory(@Buffer[2],@CBSendFileStop,SizeOf(CBSendFileStop));
      MySocket.SendBuffer(Buffer,SizeOf(CBSendFileStop)+1,True);      {中断传输文件}
    end;
    FreeAndNil(Self);
  except
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Cancel();
var
  E:IHTMLElement;
  HTML:String;
  CBSendFileCancle:TCBSendFileCancle;
  Buffer:Array[1..2048]of char;
begin
  TransmitFiles.Remove(Self);
  if not IsScreen then
  begin
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
    E.setAttribute('src',ResPath+'ImagesFileClose.gif',0);
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
    if Category = tfSend then
      E.innerHTML:='您已取消发送此文件'
    else
      E.innerHTML:='对方已取消发送此文件';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
    E.innerHTML:='<font color="#990000">已取消</font>';
    if Category = tfGet then
    begin
      HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesFileClose.gif'+'" align="absbottom"> '+FilterHTMLCode(SenderName)+' 取消了发送文件：'+FilterHTMLCode(FileName)+'</div>';
      InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
    end;
  end;
  
  if Category = tfSend then
  begin
    CBSendFileCancle.Receiver:=ReceiverID;
    CBSendFileCancle.BaseID:=BaseID;
    Buffer[1]:=skSendFileCancle;
    CopyMemory(@Buffer[2],@CBSendFileCancle,SizeOf(CBSendFileCancle));
    MySocket.SendBuffer(Buffer,SizeOf(CBSendFileCancle)+1,True);      {取消发送文件}
  end;
  FreeAndNil(Self);
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Error();
var
  E:IHTMLElement;
  HTML:String;
begin
  try
    TransmitFiles.Remove(Self);
  
    if not IsScreen then
    begin
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
      E.setAttribute('src',ResPath+'ImagesFileClose.gif',0);
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
      E.innerHTML:='传输过程中发生错误';
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
      E.innerHTML:='<font color="#990000">已停止</font>';
      HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesFileClose.gif'+'" align="absbottom"> 文件：'+FilterHTMLCode(FileName)+' 传输失败！</div>';
      InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
    end;
    
    FreeAndNil(Self);
  except
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Decline();
var
  E:IHTMLElement;
  HTML:String;
  CBSendFileResponse:TCBSendFileResponse;
  Buffer:Array[1..2048]of char;
begin
  TransmitFiles.Remove(Self);
  
  if not IsScreen then
  begin
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
    E.setAttribute('src',ResPath+'ImagesFileClose.gif',0);
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
    if Category = tfSend then
      E.innerHTML:='对方拒绝接受此文件'
    else
      E.innerHTML:='您已拒绝接受此文件';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
    if Category = tfSend then
      E.innerHTML:='<font color="#990000">已被拒绝</font>'
    else
      E.innerHTML:='<font color="#990000">已拒绝</font>';
    if Category = tfSend then
    begin
      HTML:='<div style="color:#990000"><img src="'+ResPath+'ImagesFileClose.gif'+'" align="absbottom"> '+FilterHTMLCode(ReceiverName)+' 拒绝接受文件：'+FilterHTMLCode(FileName)+'</div>';
      InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
    end;
  end;
  
  if Category = tfGet then
  begin
    CBSendFileResponse.IsAccept:=False;
    CBSendFileResponse.Receiver:=SenderID;
    CBSendFileResponse.BaseID:=BaseID;
    Buffer[1]:=skSendFileResponse;
    CopyMemory(@Buffer[2],@CBSendFileResponse,SizeOf(CBSendFileResponse));
    MySocket.SendBuffer(Buffer,SizeOf(CBSendFileResponse)+1,True);      {拒绝接受文件}
  end;
  FreeAndNil(Self);
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Accept();
var
  E:IHTMLElement;
  CBSendFileResponse:TCBSendFileResponse;
  CBPleaseCallMe:TCBPleaseCallMe;
  Buffer:Array[1..2048]of char;
  iLoop:Integer;
  IsInSameNet:Boolean;
  Employee:PEmployee;
  TransmitFile:TTransmitFile;
  NullChar:char;
  SendFileResume:TCBSendFileResume;
  FileTableUnit:PFileTableUnit;
  Start,TFCount:Integer;
begin
  if Category = tfGet then
  begin
    TFCount:=0;
    with TransmitFiles.LockList do
    try
      for iLoop:=0 to Count - 1 do
      begin
        TransmitFile:=Items[iLoop];
        if (TransmitFile.SenderID = SenderID) and (TransmitFile.ReceiverID = ReceiverID) and (TransmitFile.IsAccepted=True) then
        begin
          Inc(TFCount);
          if TFCount>=3 then
          begin
            messagebox(ChatingForm.Handle,'在其它文件或图片发送完毕之前，您不能接受新的文件传输邀请！','提示',MB_ICONINFORMATION);
            exit;
          end;
        end;
      end;
    finally
      TransmitFiles.UnlockList;
    end;
    try
      if not IsScreen then
      begin
        ChatingForm.SaveDialog.FileName:=FileName;
        if ChatingForm.SaveDialog.Execute then
        begin
          SaveFileName := ChatingForm.SaveDialog.Files.Strings[0];
          if FileExists(SaveFileName) then DeleteFile(PChar(SaveFileName));
        end
        else
        begin
          exit;
        end;
      end
      else
      begin
        SaveFileName := ResPath+'Screens'+IntToStr(SenderID)+'R'+FileName;
        if not DirectoryExists(ExtractFilePath(SaveFileName)) then CreateDir(ExtractFilePath(SaveFileName));
      end;
      if FileExists(CachePath+''+FileHashCode) then
      begin
        if IsScreen or (MessageBox(ChatingForm.handle,'此文件在上次传输时被中断，是否使用断点续传方式接收？','提示',MB_ICONQUESTION or MB_YESNO) = ID_YES) then
        begin
          FileStream:=TFileStream.Create(CachePath+''+FileHashCode,fmOpenReadWrite or fmShareDenyWrite);
          try
            FileStream.Position:=0;
            Start:=0;
            E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
            E.innerHTML:='准备接收文件（正在发送断点续传信息）...';
            Application.ProcessMessages;
            ResumedSize:=0;
            while Start<FileTable.Count do
            begin
                if FileTable.Count-Start>SizeOf(SendFileResume.ResumBuffer) then
                  SendFileResume.BufferLength:=SizeOf(SendFileResume.ResumBuffer)
                else
                  SendFileResume.BufferLength:=FileTable.Count-Start;
                
                FileStream.Read(SendFileResume.ResumBuffer,SendFileResume.BufferLength);
                SendFileResume.Start:=Start;
                Start:=Start+SendFileResume.BufferLength;
                for iLoop:=0 to SendFileResume.BufferLength-1 do
                begin
                  PFileTableUnit(FileTable.Items[SendFileResume.Start+iLoop]).IsAccepted:=SendFileResume.ResumBuffer[iLoop+1];
                  if PFileTableUnit(FileTable.Items[SendFileResume.Start+iLoop]).IsAccepted='1' then ResumedSize:=ResumedSize+FilePackSize;
                end;
                SendFileResume.Sender:=Me.ID;
                SendFileResume.Receiver:=SenderID;
                SendFileResume.BaseID:=BaseID;
                Buffer[1]:=skSendFileResume;
                CopyMemory(@Buffer[2],@SendFileResume,SizeOf(SendFileResume));
                MySocket.SendBuffer(Buffer,SizeOf(SendFileResume)+1,True); {发送续传位置信息}
                Sleep(50);
                Application.ProcessMessages;
            end;
          except
          end;
        end;
      end;
      if FileStream=nil then
      begin
        FileStream:=TFileStream.Create(CachePath+''+FileHashCode,fmCreate or fmShareDenyWrite);
        if not IsScreen then
        begin
          NullChar:='0';
          for iLoop:=0 to FileTable.Count-1 do FileStream.Write(NullChar,1);
        end;
      end;
    except
      on E: Exception do
      begin
        MessageBox(ChatingForm.handle,PChar(E.message),'错误',MB_ICONERROR);
        exit;
      end;
    end;
  end;
  IsAccepted:=True;
  StartTime:=GetTickcount;
  UsedTime:=0;
  LastGetOrResultTicket:=GetTickCount;
  RealMessengerX.TimeCheckTransmitFileError.Enabled:=True;
  if not IsScreen then
  begin
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
    if Category = tfSend then
      E.innerHTML:='准备发送文件...'
    else
      E.innerHTML:='准备接受文件...';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
    E.innerHTML:='<a href="TFStop_'+BaseID+'" title="中断传输文件" >中断</a> ';
  end;
  if Category = tfGet then
  begin
    CBSendFileResponse.IsAccept :=True;
    CBSendFileResponse.Receiver :=SenderID;
    CBSendFileResponse.BaseID   :=BaseID;
    CBSendFileResponse.IP:=MySocket.IP;
    CBSendFileResponse.Port:=MySocket.Port;
    CBSendFileResponse.LocalIP:=MySocket.LocalIP;
    CBSendFileResponse.LocalPort:=MySocket.LocalPort;
    Buffer[1]:=skSendFileResponse;
    CopyMemory(@Buffer[2],@CBSendFileResponse,SizeOf(CBSendFileResponse));
    MySocket.SendBuffer(Buffer,SizeOf(CBSendFileResponse)+1,True);      {同意接受文件}
  end
  else
  begin
    SendFileThread:=TSendFile.Create(ReceiverID,BaseID,FileStream,Self);
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Send(AcceptedSize:Int64);
begin
  UsedTime:=GetTickCount - StartTime;
  CurentSize:=AcceptedSize;
  if (UsedTime - OldUsedTime) > 250 then ShowProgress();   {显示进度}
  with FileTable do
  begin
    if CurentSize>=FileSize then
    begin
      PFileTableUnit(Items[Count-1]).IsAccepted:='1';
    end
    else
    begin
      PFileTableUnit(Items[(CurentSize div FilePackSize)-1]).IsAccepted:='1';
    end;
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Get(SendTicket:Int64);
var
  CBSendFileResult:TCBSendFileResult;
  CBSendFileCompleted:TCBSendFileCompleted;
  Buffer:Array[1..2048]of char;
  AllIsSended:Boolean;
  iLoop:Integer;
  FileTableUnit:PFileTableUnit;
  ResumeChar:Char;
begin
  UsedTime:=GetTickCount - StartTime;
  if (UsedTime - OldUsedTime) > 250 then ShowProgress();   {显示进度}
  
  with FileTable do
  begin
    if CurentSize>=FileSize then
    begin
      PFileTableUnit(Items[Count-1]).IsAccepted:='1';
      if not IsScreen then
      begin
        ResumeChar:='1';
        FileStream.Position:=Count-1;
        FileStream.Write(ResumeChar,1);
      end;
    end
    else
    begin
      PFileTableUnit(Items[(CurentSize div FilePackSize)-1]).IsAccepted:='1';
      if not IsScreen then
      begin
        ResumeChar:='1';
        FileStream.Position:=(CurentSize div FilePackSize)-1;
        FileStream.Write(ResumeChar,1);
      end;
    end;
    AllIsSended:=True;
    with FileTable do
    begin
      for iLoop:=0 to Count-1 do
      begin
        FileTableUnit:=Items[iLoop];
        if FileTableUnit.IsAccepted='0' then
        begin
          AllIsSended:=False;
          break;
        end;
      end;
    end;
    if AllIsSended then
    begin
      IsComleted:=True;
      CBSendFileCompleted.Receiver:=SenderID;
      CBSendFileCompleted.BaseID:=BaseID;
      CBSendFileCompleted.Sender:=Me.ID;
      Buffer[1]:=skSendFileCompleted;
      CopyMemory(@Buffer[2],@CBSendFileCompleted,SizeOf(CBSendFileCompleted));
      MySocket.SendBuffer(Buffer,SizeOf(CBSendFileCompleted)+1,True);
      TMoveFile.Create(Self);
      Exit;
    end;
  end;
  CBSendFileResult.Receiver        :=SenderID;
  CBSendFileResult.BaseID          :=BaseID;
  CBSendFileResult.CurentSize      :=CurentSize;
  CBSendFileResult.SendTicket      :=SendTicket;
  Buffer[1]:=skSendFileResult;
  CopyMemory(@Buffer[2],@CBSendFileResult,SizeOf(CBSendFileResult));
  MySocket.SendBuffer(Buffer,SizeOf(CBSendFileResult)+1);  {告诉对方CurentSize位置处的文件已收到}
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.ShowComplete();
var
  E:IHTMLElement;
  HTML:String;
  SaveFileStream:TFileStream;
  Buffer:Array[1..FilePackSize] of char;
  BufferSize:Integer;
  iLoop:Integer;
begin
  try
    TransmitFiles.Remove(Self);
    try
      FileStream.Free;
      FileStream:=nil;
      if Category = tfSend then (SendFileThread as TSendFile).Terminate;
    except
    end;
    
    if not IsScreen then
    begin
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(CompletedID,0) as IHTMLElement;
      E.style.width:='100%';
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(UndoneID,0) as IHTMLElement;
      E.style.width:='0%';
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
      E.innerHTML:='已完成';
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ActionID,0) as IHTMLElement;
      if Category = tfSend then
        E.innerHTML:='<font color="'+SysTextColor+'">文件发送完毕</font>'
      else
        E.innerHTML:='<font color="'+SysTextColor+'">文件接受完毕</font>　<a href="about:blankFile://_'+ExtractFilePath(SaveFileName)+'" >打开所在文件夹</a>';
      if Category = tfGet then
      begin
        HTML:='<div style="color:'+SysTextColor+'"><img src="'+ResPath+'ImagesFile.gif'+'" align="absbottom"> 您成功的从 '+FilterHTMLCode(SenderName)+' 处接收了 <a href="about:blankFile://_'+SaveFileName+'" >'+FilterHTMLCode(SaveFileName)+'</a></div>';
        if not IsScreen then InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
      end
      else
      begin
        HTML:='<div style="color:'+SysTextColor+'"><img src="'+ResPath+'ImagesFile.gif'+'" align="absbottom"> 文件 '+FilterHTMLCode(FileName)+' 发送完毕</div>';
        if not IsScreen then InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
      end;
      
    end
    else if Category = tfGet then 
    begin
      E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(ImageID,0) as IHTMLElement;
      E.setAttribute('src',SaveFileName,0);
    end;
    FreeAndNil(Self);
  except
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.ShowProgress();
var
  E              :IHTMLElement;
  speedStr,
  CurentSizeStr,
  FileSizeStr    :string;
  iLoop,Completed      :Integer;
  TransmitedSize :Int64;
begin
  Application.ProcessMessages;
  
  if IsScreen then exit;
  if UsedTime=0 then exit;
  
  if FileSize > 0 then
  begin
    TransmitedSize:=0;
    with FileTable do
    begin
      for iLoop:=0 to Count-1 do
      begin
        if PFileTableUnit(Items[iLoop]).IsAccepted='1' then
        begin
          if iLoop<Count-1 then
            TransmitedSize:=TransmitedSize+FilePackSize
          else if FileSize mod FilePackSize=0 then
            TransmitedSize:=TransmitedSize+FilePackSize
          else
            TransmitedSize:=TransmitedSize+FileSize mod FilePackSize;
        end; 
      end;
    end;
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(CompletedID,0) as IHTMLElement;
    Completed:=TransmitedSize*100 div FileSize;
    E.style.width:=IntToStr(Completed)+'%';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(UndoneID,0) as IHTMLElement;
    E.style.width:=IntToStr(100-Completed)+'%';
    
    speed:=Round((TransmitedSize-ResumedSize) / ((UsedTime-OldUsedTime) / 1000));
    OldUsedTime:=UsedTime;
    ResumedSize:=TransmitedSize;
    
    if speed > 1000*1000 then
      speedStr:=FloatToStr(StrToFloat(Copy(FloatToStr( speed / (1000*1000) ),1,3))) +'M/秒'
    else if speed > 1000 then
      speedStr:=FloatToStr(StrToFloat(Copy(FloatToStr( speed / 1000 ),1,3))) +'K/秒'
    else
      speedStr:=FloatToStr(StrToFloat(Copy(FloatToStr( speed ),1,3))) +'字节/秒';
    if (FileSize-CurentSize) > 1000 then
      FileSizeStr:=IntToStr((FileSize-TransmitedSize) div 1024) +' K'
    else
      FileSizeStr:=IntToStr((FileSize-TransmitedSize)) +' 字节';
    if CurentSize > 1000 then
      CurentSizeStr:=IntToStr(TransmitedSize div 1024) +' K'
    else
      CurentSizeStr:=IntToStr(TransmitedSize) +' 字节';
    E:=(ChatingForm.MsgContent.Document as IHTMLDocument2).all.item(PercentID,0) as IHTMLElement;
    E.innerHTML:='已传输 '+CurentSizeStr+'，剩余 '+FileSizeStr+'，速度 '+speedStr;
  end;
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.CreateHTML();
var
  HTML,FileSizeStr:String;
begin
  if not IsScreen then
  begin
    HTML:='<table width="100%" style="font-size:9pt;border:1px solid #808080;background-color:#FFFFCE;padding:2px;Scolor:'+SysTextColor+';margin-top:2px;margin-bottom:5px;filter: alpha(opacity=80);"><tr><td>';
    if FileSize > 1024 then
      FileSizeStr:=IntToStr(FileSize div 1024) +' K'
    else
      FileSizeStr:=IntToStr(FileSize) +' 字节';
    ImageID:='Image_'+BaseID;
    HTML:=HTML+'<img id="'+ImageID+'" src="'+ResPath+'ImagesFile.gif'+'" align="absbottom"> ';
    if Category = tfSend then
      HTML:=HTML+' 您要给 '+FilterHTMLCode(ReceiverName)+' 发送文件：'+FilterHTMLCode(FileName)+'（'+FileSizeStr+'）<br>'
    else
      HTML:=HTML+FilterHTMLCode(SenderName)+' 要给您发送文件：'+FilterHTMLCode(FileName)+'（'+FileSizeStr+'）<br>';
    PercentID:='Percent_'+BaseID;
    if Category = tfSend then
      HTML:=HTML+'<span id="'+PercentID+'" style="position:relative;top:18px;left:5px;">等待对方回应...</span><br>'
    else
      HTML:=HTML+'<span id="'+PercentID+'" style="position:relative;top:18px;left:5px;">等待您的回应...</span><br>';
    HTML:=HTML+'<table  width="288" border="0" cellpadding="0" cellspacing="1" bgcolor="#808080" style="margin-bottom:5px">'+
             '   <tr bgcolor="#FFFFCE">'+
             '     <td>'+
  		       '       <table width="288" border="0" cellpadding="0" cellspacing="0" bgcolor="#FFFFCE" height="18">'+
    	       '       <tr bgcolor="#FFFFCE">';
    CompletedID:='Completed_'+BaseID;
    HTML:=HTML+'<td id="'+CompletedID+'" width="0%" bgcolor="#5FFF3F"></td>';
  
    UndoneID:='Undone_'+BaseID;
    HTML:=HTML+'<td id="'+UndoneID+'" width="100%" ></td>';
    HTML:=HTML+'      </tr>'+
             '      </table>'+
             '    </td>'+
  		       '  </tr>'+
    	       '</table>';
             
    ActionID:='Action'+BaseID;
    HTML:=HTML+'<span id="'+ActionID+'">';
    if Category = tfSend then
      HTML:=HTML+'<a href="TFCancel_'+BaseID+'" title="取消发送此文件">取消</a> '
    else
      HTML:=HTML+'<a href="TFAccept_'+BaseID+'" title="接受此文件">接受</a>　'+
               '<a href="TFdecline_'+BaseID+'" title="拒绝接受此文件">拒绝</a> ';
    HTML:=HTML+'</span>';
    HTML:=HTML+'</td></tr></table>';
  end
  else
  begin
    HTML:='<DIV style="padding-bottom:2px;color:'+SysTextColor+'">'+SenderName+' '+TimeToStr(Now)+' ：<br> ';
    ImageID:='Image_'+BaseID;
    if Category = tfSend then
    begin
      HTML:=HTML+'<img id="'+ImageID+'" src="'+FileName+'" hspace="2" vspace="2"> ';
    end
    else
    begin
      HTML:=HTML+'<img id="'+ImageID+'" src="'+ResPath+'Imagesprogress.gif'+'" hspace="2" vspace="2"> ';
      Accept();
    end;
    HTML:=HTML+' </DIV>';
  end;
  InsertHTML(ChatingForm,ChatingForm.MsgContent,HTML);
end;
{------------------------------------------------------------------------------}
procedure TTransmitFile.Logout();
begin
  if IsAccepted then
    if SenderID = Me.ID then
      Stop(ReceiverID)
    else
      Stop(SenderID)
  else
    Cancel;
end;
{------------------------------------------------------------------------------}
{结束文件传输}
procedure TTransmitFile.Close();
begin
  if IsAccepted then
    Stop(Me.ID)
  else if Category = tfSend then
    Cancel
  else
    Decline;
end;
{------------------------------------------------------------------------------}
procedure ChangeAllColor(CustColor:TColor);
var
  iLoop:Integer;
begin
    RealMessengerX.PnlRoot.Color:=CustColor;
    ConvertBitmapToColor(RealMessengerX.ImgMyState.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgTitleLeft.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgTitle.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgTitleRight.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgToolbarLeft.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgToolbar.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgToolbarRight.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgBorderLeft.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgBorderRight.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgBottomLeft.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgBottom.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgBottomRight.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgMin.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgClosed.Picture.Bitmap,CustColor);
    ConvertBitmapToColor(RealMessengerX.ImgEmail.Picture.Bitmap,CustColor);
    RealMessengerX.Gauge.ForeColor:=CustColor;
    RealMessengerX.Repaint;
    RealMessengerX.TrevUserList.Repaint;
    for iLoop:=0 to ChatingFormList.Count -1 do ChangeChatingFormColor(ChatingFormList.Items[iLoop],CustColor);
end;
{------------------------------------------------------------------------------}
procedure ChangeChatingFormColor(ChatingForm:TChatingForm;CustColor:TColor);
begin
  ConvertBitmapToColor(ChatingForm.ImgOpenVideoForm.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image10.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image11.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image12.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image16.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image17.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image18.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.ImgArrow.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image32.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image33.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image34.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.ImgMic.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.ImgSpk.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image1.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image2.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image3.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image4.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image5.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image6.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image13.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image14.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image15.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image19.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image20.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image21.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image8.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image9.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image22.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image23.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image25.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image26.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image35.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image36.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.Image37.Picture.Bitmap,CustColor);
  ChatingForm.ImgListHistory.GetBitmap(0,ChatingForm.ImgHistory.Picture.Bitmap);
  ChatingForm.ImgListClose.GetBitmap(0,ChatingForm.ImgClose.Picture.Bitmap);
  ChatingForm.ImgListSend.GetBitmap(0,ChatingForm.ImgSend.Picture.Bitmap);
  ConvertBitmapToColor(ChatingForm.ImgHistory.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.ImgClose.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.ImgSend.Picture.Bitmap,CustColor);
  ConvertBitmapToColor(ChatingForm.ImgSendType.Picture.Bitmap,CustColor);
  ChatingForm.MMMixerSliderIn.ThumbColor:=CustColor;
  ChatingForm.MMMixerSliderInChange(ChatingForm.MMMixerSliderIn);
  ChatingForm.MMMixerSliderOut.ThumbColor:=CustColor;
  ChatingForm.MMMixerSliderInChange(ChatingForm.MMMixerSliderOut);
  try
    ChatingForm.SetBrowserStyle();
  except
  end;
  ChatingForm.Refresh;
  ChatingForm.PnlLeftTop.Refresh;
  ChatingForm.PnlLeftBottom.Refresh;
  ChatingForm.PnlRightBottom.Refresh;
  ChatingForm.TVUserList.Refresh;
end;
{------------------------------------------------------------------------------}
procedure FocusForm(form:TForm);
begin
  if (GetForegroundWindow<>form.Handle) then FlashWindow(form.Handle,True);
end;
procedure PlayEventSound(FileName:string);
begin
  try
    PlaySound(PChar(FileName),0,SND_ASYNC or SND_FILENAME);
  except
  end;
end;
{------------------------------------------------------------------------------}
function FindTransmitFileByBaseID(BaseID:String):TTransmitFile;
var
  iLoop:Integer;
  TransmitFile:TTransmitFile;
begin
  Result:=nil;
  with TransmitFiles.LockList do
  try
    for iLoop:=0 to Count - 1 do
    begin
      TransmitFile:=Items[iLoop];
      if AnsiSameText(TransmitFile.BaseID,BaseID) then
      begin
        Result:=TransmitFile;
        exit;
      end
    end;
  finally
    TransmitFiles.UnlockList;
  end;
end;
{------------------------------------------------------------------------------}
function FindVideoHandShakeByBaseID(BaseID:String):TVideoHandShake;
var
  iLoop:Integer;
  VideoHandShake:TVideoHandShake;
begin
  Result:=nil;
  with VideoHandShakes.LockList do
  try
    for iLoop:=0 to Count - 1 do
    begin
      VideoHandShake:=Items[iLoop];
      if AnsiSameText(VideoHandShake.BaseID,BaseID) then
      begin
        Result:=VideoHandShake;
        exit;
      end
    end;
  finally
    VideoHandShakes.UnlockList;
  end;
end;
{------------------------------------------------------------------------------}
function FindVideoHandShakeByID(ID:Integer):TVideoHandShake;
var
  iLoop:Integer;
  VideoHandShake:TVideoHandShake;
begin
  Result:=nil;
  with VideoHandShakes.LockList do
  try
    for iLoop:=0 to Count - 1 do
    begin
      VideoHandShake:=Items[iLoop];
      if VideoHandShake.ID=ID then
      begin
        Result:=VideoHandShake;
        exit;
      end
    end;
  finally
    VideoHandShakes.UnlockList;
  end;
end;
{------------------------------------------------------------------------------}
function FindAudioHandShakeByBaseID(BaseID:String):TAudioHandShake;
var
  iLoop:Integer;
  AudioHandShake:TAudioHandShake;
begin
  Result:=nil;
  with AudioHandShakes.LockList do
  try
    for iLoop:=0 to Count - 1 do
    begin
      AudioHandShake:=Items[iLoop];
      if AnsiSameText(AudioHandShake.BaseID,BaseID) then
      begin
        Result:=AudioHandShake;
        exit;
      end
    end;
  finally
    AudioHandShakes.UnlockList;
  end;
end;
{------------------------------------------------------------------------------}
function FindAudioHandShakeByID(ID:Integer):TAudioHandShake;
var
  iLoop:Integer;
  AudioHandShake:TAudioHandShake;
begin
  Result:=nil;
  with AudioHandShakes.LockList do
  try
    for iLoop:=0 to Count - 1 do
    begin
      AudioHandShake:=Items[iLoop];
      if AudioHandShake.ID=ID then
      begin
        Result:=AudioHandShake;
        exit;
      end
    end;
  finally
    AudioHandShakes.UnlockList;
  end;
end;
{------------------------------------------------------------------------------}
function FilterHTMLCode(HTML:String):String;
var
  jLoop:Integer;
  UrlStart,UrlEnd:Integer;
  TempStr:String;
begin
  HTML:=AnsiReplaceStr(HTML,'<','&lt;');
  HTML:=AnsiReplaceStr(HTML,'>','&gt;');
  HTML:=AnsiReplaceStr(HTML,#13,'&nbsp;<br>');
  HTML:=AnsiReplaceStr(HTML,#32,'&nbsp;');
  for jLoop:=1 to Length(Faces) do
    HTML:=AnsiReplaceStr(HTML,FacesChar[jLoop],'<img src="'+ResPath+'/Face/'+IntToStr(jLoop)+'.gif" align="absMiddle" hspace="1" >');
  TempStr:='';
  UrlStart:=AnsiPos('http://',HTML);
  while UrlStart>0 do
  begin
    TempStr:=TempStr+Copy(HTML,1,UrlStart-1);
    HTML:=Copy(HTML,UrlStart,Length(HTML));
    UrlEnd:=AnsiPos('&nbsp;',HTML);
    if UrlEnd<=0 then UrlEnd:=Length(HTML)+1;
    TempStr:=TempStr+'<a href="'+Copy(HTML,1,UrlEnd-1)+'" target="_blank"><font color="#0000ff">'+Copy(HTML,1,UrlEnd-1)+'</font></a>';
    HTML:=Copy(HTML,UrlEnd,Length(HTML));
    UrlStart:=AnsiPos('http://',HTML);
  end;
  TempStr:=TempStr+Copy(HTML,1,Length(HTML));
  Result:=TempStr;
end; 
{------------------------------------------------------------------------------}
function GetHostIP(HostName: String): String;
var
   buf:pChar;
   iWsaRet:Integer;
   Data:WSAData;
   hostent:PHostEnt;
begin
   Result := '';
   iWsaRet := WSAStartup($101,Data);
   if iWsaRet<>0 then
   begin
      ShowMessage('Socket initialize error!');
      Exit;
   end;
   buf := Allocmem(60);
   strcopy(buf,PChar(HostName));
   if Trim(buf)='' then
      gethostname(buf,60);
   hostent := gethostbyname(buf);
   Freemem(buf,60);
   if hostent=nil then
      Exit;
   Result  := inet_ntoa(pinAddr(hostent^.h_addr^)^);
   WSACleanup();
end;
{------------------------------------------------------------------------------}
function  OpenChatingForm(Room:ChatRoom;OpenNew:Boolean = True):TChatingForm;
var
  iLoop,i,j:Integer;
  ChatingForm: TChatingForm;
  Finded:Boolean;
  PEmployeeData:PEmployee;
begin
  Result:=nil;
  for iLoop:=1 to Room.UserCount do
  begin
    if Room.Users[iLoop]=Me.ID then continue;
    PEmployeeData:=FindEmployeeByID(Room.Users[iLoop]);
    if PEmployeeData=nil then continue;
    if PEmployeeData.MySocket=nil then PEmployeeData.MySocket:=TMySocket.Create(PEmployeeData.ID,RealMessengerX.ClientTCP,True);
  end;
  if (Room.UserCount<=0) or (Room.UserCount>16) then exit;
  
  for iLoop:=0 to ChatingFormList.Count - 1 do
  begin
    ChatingForm:=ChatingFormList.Items[iLoop];
    if (ChatingForm.RoomInfo.UserCount = Room.UserCount) then
    begin
      Finded:=False;
      
      for i:=1 to ChatingForm.RoomInfo.UserCount do
      begin
        Finded:=False;
        for j:=1 to Room.UserCount do
        begin
          if ChatingForm.RoomInfo.Users[i] = Room.Users[j] then
          begin
            Finded:=True;
            break;
          end;
        end;
        if not Finded then break;
      end;
      if Finded then
      begin
        Result:=ChatingForm;
        exit;
      end;
      
    end;
  end;
  if not OpenNew then
  begin
    Result:=nil;
    exit;
  end;
  ChatingForm:=TChatingForm.Create(RealMessengerX);
  ChangeChatingFormColor(ChatingForm,EndColor);
  ChatingForm.RoomInfo:=Room;
  ChatingFormList.Add(ChatingForm);
  Result:=ChatingForm;
end;
{------------------------------------------------------------------------------}
function GetSpecialFolderDir(const folderid:integer):string;
var
    pidl:pItemIDList;
    buffer:array [ 0..255 ] of char ;
begin
    SHGetSpecialFolderLocation( application.Handle , folderid, pidl);
    SHGetPathFromIDList(pidl, buffer);
    result:=strpas(buffer);
end;
{------------------------------------------------------------------------------}
procedure SaveHistory(CBMessage:TCBMessage);
var
  HistoryFile,MyHistoryPath:String;
  HistoryTextFile:TextFile;
  iLoop,FirstSessionID,LastSessionID:Integer;
  SenderName,ReceiverName:String;
  Xml:TXMLDocument;
  PEmployeeData:PEmployee;
  MsgContent,
  hexString,
  StyleText:String;
begin
  try
    MyHistoryPath:=HistoryPath+''+IntToStr(Me.ID);
    if not DirectoryExists(MyHistoryPath) then CreateDir(MyHistoryPath);
    FirstSessionID:=Me.ID;
    if CBMessage.Receiver=Me.ID then
    begin
      HistoryFile:=MyHistoryPath+''+IntToStr(CBMessage.Sender)+'.xml';
      LastSessionID:=CBMessage.Sender;
      ReceiverName:=Me.Name;
      with Employees.LockList do
      try
        for iLoop:=0 to Count-1 do
        begin
          PEmployeeData:=Items[iLoop];
          if PEmployeeData.ID=CBMessage.Sender then
          begin
            SenderName:=PEmployeeData.Name;
            break;
          end;
        end;
      finally
        Employees.UnlockList;
      end;
    end
    else
    begin
      HistoryFile:=MyHistoryPath+''+IntToStr(CBMessage.Receiver)+'.xml';
      LastSessionID:=CBMessage.Receiver;
      SenderName:=Me.Name;
      with Employees.LockList do
      try
        for iLoop:=0 to Count-1 do
        begin
          PEmployeeData:=Items[iLoop];
          if PEmployeeData.ID=CBMessage.Receiver then
          begin
            ReceiverName:=PEmployeeData.Name;
            break;
          end;
        end;
      finally
        Employees.UnlockList;
      end;
    end;
    AssignFile(HistoryTextFile,HistoryFile);
    if not FileExists(HistoryFile) then
    begin
      Rewrite(HistoryTextFile);
      try
        Writeln(HistoryTextFile,'<?xml version="1.0" encoding="gb2312"?>');
        Writeln(HistoryTextFile,'<?xml-stylesheet type=''text/xsl'' href=''../History.xsl''?>');
        Writeln(HistoryTextFile,'<Log FirstSessionID="'+IntToStr(FirstSessionID)+'" LastSessionID="'+IntToStr(LastSessionID)+'">');
        Writeln(HistoryTextFile,'</Log>');
      finally
        CloseFile(HistoryTextFile);
      end;
    end;
    StyleText:='font-family:'+CBMessage.Name;
    //设置字体
    hexString:=IntToHex(CBMessage.Color,6);   //获取颜色的16进制格式
    StyleText:=StyleText+';color:#'+Copy(hexString,5,2)+Copy(hexString,3,2)+Copy(hexString,1,2);  //将BGR颜色转换为RGB颜色
    StyleText:=StyleText+';font-size:'+IntToStr(CBMessage.Size)+'pt';
    if CBMessage.fsBold then StyleText:=StyleText+';font-weight:bold';
    if CBMessage.fsItalic then StyleText:=StyleText+';font-style:italic';
    StyleText:=StyleText+';text-decoration:';
    if CBMessage.fsUnderline then StyleText:=StyleText+' underline ';
    if CBMessage.fsStrikeOut then StyleText:=StyleText+' line-through ';
    
    MsgContent:=Copy(CBMessage.Content,1,CBMessage.Length);  //获得消息内容
    MsgContent:=DESryStr(MsgContent,DESKEY);
    MsgContent:=AnsiReplaceStr(MsgContent,'<','&lt;');
    MsgContent:=AnsiReplaceStr(MsgContent,'>','&gt;');
    Xml:= TXMLDocument.Create(nil);
    try
      Xml.LoadFromFile(HistoryFile);
      Xml.Active:=True;
      Xml.XML.Text:=Copy(Xml.XML.Text,1,Length(Xml.XML.Text)-8);
      Xml.XML.Text:=Xml.XML.Text+'<Message Date="'+DateToStr(CBMessage.SendDateTime)+'" Time="'+TimeToStr(CBMessage.SendDateTime)+'" DateTime="'+DateToStr(CBMessage.SendDateTime)+'T'+TimeToStr(CBMessage.SendDateTime)+'3Z" SessionID="'+IntToStr(CBMessage.Sender)+'">'+
                  '<From>'+
                  '<User FriendlyName="'+SenderName+'"/>'+
                  '</From>'+
                  '<To>'+
                  '<User FriendlyName="'+ReceiverName+'"/>'+
                  '</To>'+
                  '<Text Style="'+StyleText+'">'+MsgContent+'</Text>'+
                  '</Message>'+
                  '</Log>';
                  
      Rewrite(HistoryTextFile);
      Writeln(HistoryTextFile,Xml.XML.Text);
      Xml.Active:=False;
    finally
      Xml.Free;
      CloseFile(HistoryTextFile);
    end;
  except
  end;
end;
{------------------------------------------------------------------------------}
procedure InsertHTML(ChatingForm:TChatingForm;IE:TWebbrowser;HTML:String);
var
  DoC: IHTMLDocument2;
begin
  Doc := IE.Document as IHTMLDocument2;
  Doc.body.innerHTML:=Doc.body.innerHTML+HTML;
  sendMessage(GetWindow(GetWindow(IE.Handle,GW_CHILD),GW_CHILD), WM_VSCROLL, SB_BOTTOM, 0); 
  sendMessage(GetWindow(GetWindow(IE.Handle,GW_CHILD),GW_CHILD), WM_VSCROLL, SB_BOTTOM, 0); 
  sendMessage(GetWindow(GetWindow(IE.Handle,GW_CHILD),GW_CHILD), WM_VSCROLL, SB_BOTTOM, 0);
  if ChatingForm<>nil then
  begin
    with ChatingForm do
    begin
      if (not Focused) and (GetForegroundWindow<>Handle) and ((not Pushed and not Visible) or (Pushed and Visible)) and (not DontPlaySound) then
      begin
        PlayEventSound(MsgSound);
        FocusForm(ChatingForm);
      end;
    end
  end;
end;
{------------------------------------------------------------------------------}
procedure ShowMsg(ChatingForm:TChatingForm;IE:TWebbrowser;SenderName:String;CBMessage:TCBMessage;Save:Boolean=True);
var
  MsgContent,
  hexString,
  HTML:String;
begin
  MsgContent:='';
  MsgContent:=SenderName+' '+DateTimeToStr(CBMessage.SendDateTime)+' ：';
  MsgContent:=FilterHTMLCode(MsgContent);
  HTML:='<DIV style="padding-bottom:2px;color:'+SysTextColor+'">'+MsgContent+'</DIV>';
  HTML:=HTML+'<DIV style="padding-left:9px;padding-bottom:2px;';
  HTML:=HTML+';font-family:'+CBMessage.Name;
  hexString:=IntToHex(CBMessage.Color,6);
  HTML:=HTML+';color:#'+Copy(hexString,5,2)+Copy(hexString,3,2)+Copy(hexString,1,2);
  HTML:=HTML+';font-size:'+IntToStr(CBMessage.Size)+'pt';
  if CBMessage.fsBold then HTML:=HTML+';font-weight:bold';
  if CBMessage.fsItalic then HTML:=HTML+';font-style:italic';
  HTML:=HTML+';text-decoration:';
  if CBMessage.fsUnderline then HTML:=HTML+' underline ';
  if CBMessage.fsStrikeOut then HTML:=HTML+' line-through ';
  MsgContent:=Copy(CBMessage.Content,1,CBMessage.Length);
  MsgContent:=DESryStr(MsgContent,DESKEY);
  MsgContent:=FilterHTMLCode(MsgContent);
  HTML:=HTML+'">'+MsgContent+' </DIV>';
  InsertHTML(ChatingForm,IE,HTML);
  if Save then SaveHistory(CBMessage);
end;
{------------------------------------------------------------------------------}
function jfForceForeGroundWindow(hwnd: THandle): boolean;
const
  SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
  SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
  ForegroundThreadID: DWORD;
  ThisThreadID : DWORD;
  timeout : DWORD;
begin
  if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);  
  if GetForegroundWindow = hwnd then Result := true
  else begin
    if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4))
        or((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
             ((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and
                    (Win32MinorVersion > 0)))) then
    begin
      Result := false;
      ForegroundThreadID :=
      GetWindowThreadProcessID(GetForegroundWindow,nil);
      ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
      if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
      begin
        BringWindowToTop(hwnd);
        SetForegroundWindow(hwnd);
        AttachThreadInput(ThisThreadID, ForegroundThreadID, false);
        Result := (GetForegroundWindow = hwnd);
      end;
      if not Result then
      begin
        SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
        SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0),SPIF_SENDCHANGE);
        BringWindowToTop(hwnd);
        SetForegroundWindow(hWnd);
        SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0,TObject(timeout), SPIF_SENDCHANGE);
      end;
    end
    else begin
      BringWindowToTop(hwnd);
      SetForegroundWindow(hwnd);
    end;
      Result := (GetForegroundWindow = hwnd);
  end;
end;
{------------------------------------------------------------------------------}
{HostToIP}
function HostToIP(Name: string; var Ip: string): Boolean;
var
  wsdata : TWSAData;
  hostName : array [0..255] of char;
  hostEnt : PHostEnt;
  addr : PChar;
begin
  WSAStartup ($0101, wsdata);
  try
    gethostname (hostName, sizeof (hostName));
    StrPCopy(hostName, Name);
    hostEnt := gethostbyname (hostName);
    if Assigned (hostEnt) then
      if Assigned (hostEnt^.h_addr_list) then begin
        addr := hostEnt^.h_addr_list^;
        if Assigned (addr) then begin
          IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
          byte (addr [1]), byte (addr [2]), byte (addr [3])]);
          Result := True;
        end
        else
          Result := False;
      end
      else
        Result := False
    else begin
      Result := False;
    end;
  finally
    WSACleanup;
  end
end;
end.

						