RealICQClient/Client/Services/HtmlService.pas

 unit HtmlService;

interface

uses
  Classes, SysUtils, Forms, SHDocVw, Graphics, MSHTML, StrUtils, Variants, ActiveX;

type
  THtmlService = class
  private
    procedure InsertHTML(Webbrowser: TWebbrowser; HTML: string);
    procedure GoBottom(Webbrowser: TWebbrowser);


  public
    procedure ShowSendMessageTooQuickly(Webbrowser: TWebbrowser);
    procedure AddMessageToWebBrowser(SenderID: String;
      SenderName, FontStr, MessageStr: String;
      SendDateTime: TDateTime;
      var NoFoundFaces: TStringList;
      Webbrowser: TWebbrowser;
      ShowSendFailed: Boolean = False;
      IsHistory: Boolean = False);
    procedure SetDOMStyle(Doc: IHTMLDocument2; AWindowColor: TColor);
    function FilterHTMLCode(HTML: string; AllowURL: Boolean = True): string;
    class function GetService: THtmlService; static;
  end;

implementation

uses
  Windows, xFonts, DateUtils, Types, UsersService, FaceService, RealICQColors;

var
  AHtmlService: THtmlService;

const
  InfomationPicture: String = 'Images\Info.gif';

procedure THtmlService.GoBottom(Webbrowser: TWebbrowser);
var
  MaxScrollHeight: Integer;
  DoC: IHTMLDocument2;
begin
  Doc := Webbrowser.Document as IHTMLDocument2;

  Application.ProcessMessages;
  Sleep(10);
  Application.ProcessMessages;
  try
    MaxScrollHeight := Doc.body.getAttribute('ScrollHeight', 0) + 10000; //获得滚动条最大高度
    Webbrowser.OleObject.Document.ParentWindow.ScrollBy(0, MaxScrollHeight); //滚动到最右最下
    Application.ProcessMessages;
    Webbrowser.OleObject.Document.ParentWindow.ScrollBy(0, MaxScrollHeight); //滚动到最右最下
  except
  end;
end;

function THtmlService.FilterHTMLCode(HTML:String; AllowURL: Boolean = True):String;
var
  UrlStart,UrlEnd,iLoop:Integer;
  TempStr:String;
begin
  HTML := AnsiReplaceStr(HTML,'&', '&');
  HTML := AnsiReplaceStr(HTML,'<', '&lt;');
  HTML := AnsiReplaceStr(HTML,'>', '&gt;');
  HTML := AnsiReplaceStr(HTML,#13, '&nbsp;<br>');
  HTML := AnsiReplaceStr(HTML,#32, '&nbsp;');

  if AllowURL then
  begin
    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
      begin
        for iLoop:=1 to length(HTML) do
        begin
          if ByteType(HTML,iLoop) <> mbSingleByte then
            begin
              UrlEnd := iLoop;
              Break;
            end;
        end;
      end;
      
      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
  else
  begin
    Result := HTML;
  end;
end;

class function THtmlService.GetService: THtmlService;
begin
    if AHtmlService = nil then
    AHtmlService := THtmlService.Create;

  Result := AHtmlService;
end;

procedure THtmlService.ShowSendMessageTooQuickly(Webbrowser: TWebbrowser);
var
  AHtml: string;
begin
  AHtml := '<table width="100%" style="font-size:9pt;border:0px; padding:2px; color:#990000; margin-top:2px;margin-bottom:5px;"><tr><td>';
  AHtml := AHtml+'<img src="' + ExtractFilePath(Application.ExeName) + InfomationPicture + '" align="texttop"> ';
  AHtml := AHtml+'<span>';
  AHtml := AHtml + '抱歉，您发送消息的速度太快了！';
  AHtml := AHtml + '</span>';
  AHtml := AHtml + '</td></tr></table>';
  InsertHTML(Webbrowser, AHtml);
end;

procedure THtmlService.InsertHTML(Webbrowser: TWebbrowser; HTML: String);
var
  DoC: IHTMLDocument2;
begin
  Doc := Webbrowser.Document as IHTMLDocument2;
  Doc.body.innerHTML:=Doc.body.innerHTML + HTML;
  GoBottom(Webbrowser);
end;

procedure THtmlService.AddMessageToWebBrowser(SenderID: String;
  SenderName, FontStr, MessageStr: String;
  SendDateTime: TDateTime;
  var NoFoundFaces: TStringList;
  Webbrowser: TWebbrowser;
  ShowSendFailed: Boolean = False;
  IsHistory: Boolean = False);
var
  MsgContent,
  HexString,
  HTML,
  SenderColor: String;
  TextFont: TFont;
  ID:String;
begin
  ID := IntToStr(GetTickCount);
  TextFont := TFont.Create;
  StringToFont(FontStr, TextFont);
  MsgContent :=FilterHTMLCode(SenderName);
  MsgContent := MsgContent +'(<a href="OpenRightMenu,'+SenderId+'">个人信息</a>)';
  if CompareDate(Now, SendDateTime) = EqualsValue then
    MsgContent := MsgContent +' '+ TimeToStr(SendDateTime)
  else
    MsgContent := MsgContent +' '+DateTimeToStr(SendDateTime);

  if ShowSendFailed then
    MsgContent := MsgContent + '（消息发送超时）';

  if not IsHistory then
    SenderColor := '#009900'
  else
    SenderColor := '#686868';
  
  HTML := '<DIV style="padding-bottom:2px; padding-top:2px; color:' + SenderColor + '">' + MsgContent +'</DIV>';
  HTML := HTML + '<DIV style="padding-left:9px; padding-bottom:2px;';

  //设置字体
  HTML := HTML + ';font-family:' + TextFont.Name;
  HexString := IntToHex(TextFont.Color, 6);   //获取颜色的16进制格式
  HTML := HTML + ';color:#' + Copy(HexString,5,2) + Copy(HexString,3,2) + Copy(HexString,1,2);  //将BGR颜色转换为RGB颜色
  HTML := HTML + ';font-size:' + IntToStr(TextFont.Size) + 'pt';
  if fsBold in TextFont.Style then HTML := HTML + ';font-weight:bold';
  if fsItalic in TextFont.Style then HTML := HTML + ';font-style:italic';
  HTML := HTML + ';text-decoration:';
  if fsUnderline in TextFont.Style then HTML := HTML + ' underline ';
  if fsStrikeOut in TextFont.Style then HTML := HTML + ' line-through ';


  MsgContent := FilterHTMLCode(MessageStr); //过滤HTML代码
  MsgContent := TFaceService.GetService.ParseToHtml(MsgContent, SenderID, NoFoundFaces);

  HTML := HTML + '"><span id="' + ID + '">' + MsgContent + '</span> </DIV>';
  InsertHTML(WebBrowser, HTML);
end;

procedure THtmlService.SetDOMStyle(Doc:IHTMLDocument2; AWindowColor: TColor);
var
  v: Variant;
  CurrentColor,
  CssColor: String;
begin
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := '<html dir="ltr" lang="zh">'
        + '<head>'
        + '<META http-equiv="Content-Type" content="text/html; charset=gb2312">'
        + '<body link="#0000FF" vlink="#0000FF" alink="#0000FF" hlink="#0000FF" bgcolor="#FFFFFF" oncontextmenu="location.href=''PopMenu'';return false;" >'
        + '</body>'
        + '</head>';
  doc.write(PSafeArray(TVarData(v).VArray));


  try
    CurrentColor := IntToHex(ConvertColorToColor($00CDCDCD, AWindowColor), 6);
    CssColor := '#' + Copy(CurrentColor,5,2) + Copy(CurrentColor,3,2) + Copy(CurrentColor,1,2);
  except
  end;
  Doc.body.language := 'gb2312';
  Doc.body.style.cssText:='SCROLLBAR-FACE-COLOR:' + CssColor + ';' +
			  'SCROLLBAR-HIGHLIGHT-COLOR: ButtonHighLight;' +
			  'SCROLLBAR-SHADOW-COLOR: ButtonShadow;' +
			  'SCROLLBAR-ARROW-COLOR: #333333;' +
			  'SCROLLBAR-3DLIGHT-COLOR:' + CssColor + ';' +
			  'SCROLLBAR-TRACK-COLOR:' + CssColor + ';' +
			  'SCROLLBAR-DARKSHADOW-COLOR:' + CssColor + ';' +
			  'word-break: break-all;' +
        'background-attachment: fixed;' +
        'background-repeat: no-repeat;' +
        'background-position: left top;';

end;

initialization

finalization
  if AHtmlService <> nil then
    FreeAndNil(AHtmlService);

end.