elmimeviewer_htmltext.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 509 行

PAS
509 行
字号 
// File Version: 2004-04-16
unit ElMimeViewer_HtmlText;

// _HTML_IE_
{$i ElMimeViewer_Options.inc}

{$IFDEF DEV_COMMENTS}
(*
todo:
  uncorrected html:
    ...
    <head>
    <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=Windows-1252">
    ...
*)
{$ENDIF IFDEF DEV_COMMENTS}
interface

uses
  // System units:
  SysUtils, Classes,
  {$IFDEF DELPHI_NET}
  System.ComponentModel,
  {$ENDIF}
  // ElMime units:
  SBMIMETypes,
  SBMIMEUtils,
  SBMIMEClasses,
  SBMIMEStream,
  SBMIME,
  // ElMime Demo units:
  ElMimeViewer_DataCommon,
  // HTML IE
  {$IFDEF _HTML_IE_}
  OleCtrls, SHDocVw, ActiveX,
  {$ENDIF}
  // other units:
  Windows, Messages, {$IFDEF D_6_UP}Variants,{$ENDIF} Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls;

type

  TFrame = TElMimePlugFrame;

  TfraHtmlText = class(TFrame)
    PageControl: TPageControl;
    TabSheetHtml: TTabSheet;
    TabSheetSource: TTabSheet;
    Memo: TMemo;
    TabSheetOptions: TTabSheet;
    cbShowHtml: TCheckBox;
    procedure cbShowHtmlClick(Sender: TObject);
    procedure MemoChange(Sender: TObject);
    procedure PageControlChanging(Sender: TObject;
      var AllowChange: Boolean);
  private
    { Private declarations }
    fModified: Boolean;
    {$IFDEF _HTML_IE_}
  private
    WebBrowser: TWebBrowser;
    fHtmlStream: TAnsiStringStream;
    IpStream: IPersistStreamInit;
    Timer: TTimer;
    procedure UpdateHtml;
    procedure CheckComplete;
    procedure ActivateDocument(bGoToBlankPage: Boolean = False);
    procedure TimerTimer(Sender: TObject);
    {$ENDIF IFDEF _HTML_IE_}
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function IsSupportedThisMessapePart(mp: TElMessagePart; TagInfo: TTagInfo; Node: TTreeNodeInfo): Boolean; override;
    class function SetNodeImageIndex(Node: TTreeNodeInfo; mp: TElMessagePart): Boolean; override;
    function GetCaption: string; override;
    procedure WriteHTMLCode(sm: TElCustomMemoryStream); override;
    procedure UpdateView; override;
    procedure BeforeRemoveParent; override;
  protected
    procedure Init(mp: TElMessagePart; TagInfo: TTagInfo; Node: TTreeNodeInfo; bShow: Boolean); override;
  end;

implementation

{$R *.dfm}

uses ElMimeViewer_PlainText, ElMimeViewer_Image;

{ TfraHtmlText }

{------------------------------------------------------------------------------}

class function TfraHtmlText.IsSupportedThisMessapePart(mp: TElMessagePart;
  TagInfo: TTagInfo; Node: TTreeNodeInfo): Boolean;
var
  wsContentSubtype, wsName: TWideString;
  sName: AnsiString;
  f: TElMessageHeaderField;

  function BinaryAutodetect: Boolean;
  var
    i: integer;
    Buffer: TBytes;
    BufferSize: Integer;
    {$IFDEF DELPHI_NET}
    sData: TWideString;
    {$ELSE}
    ws: TWideString;
    sData: string;
    {$ENDIF}
  const
    cHtmlWords: array[0..6]of string = (
      '<!DOCTYPE HTML',
      '<HTML>',
      '</table>',
      '<tr><td>',
      '<table cellspacing=',
      '</td></tr>',
      '</font>'
      //'<align=center>'
    );
  begin
    Result := False;
    if mp.IsText then
    begin
      mp.GetText({$IFDEF DELPHI_NET}sData{$ELSE}ws{$ENDIF});
      {$IFNDEF DELPHI_NET}
      sData := ws;
      {$ENDIF}
    end
    else
    begin
      BufferSize := 0;
      mp.GetData(Buffer, BufferSize);
      {$IFDEF DELPHI_NET}
        sData := StringOf(Buffer);
      {$ELSE}
        GetStringOf(Buffer, sData);
      {$ENDIF IFDEF DELPHI_NET}
    end;

    for i:=Low(cHtmlWords) to High(cHtmlWords) do
    begin
      if (PosExSafe(cHtmlWords[i], sData, 1, 100) > 0) then
      begin
        Result := True;
        exit;
      end;
    end;
  end;
begin
  Result := False;
  if (TagInfo<>tiBody) or (Node=nil) or (mp=nil) or (mp.IsMultipart) then
    exit;
  Result := mp.IsTextHtml;
  if not Result then
  begin
    if mp.IsApplication then
    begin
      wsContentSubtype := mp.ContentSubtype;
      if WideSameText(wsContentSubtype, 'octet-stream') then
      begin
        wsName := mp.FileName;
        DeleteQuotationMarks(wsName);
        sName := LowerCase(Trim(ExtractFileExtension(wsName)));
        if wsName <> '' then
        begin
          if PosExSafe('\'+sName+'\', '\htm\html\shtm\shtml\xml\xls\css\php\')>0 then
          begin
            if (sName = 'cgi') then
            begin
              f := mp.HeaderContentLocationField;
              if Assigned(f) then
              begin
                wsName := LowerCase(f.Value);
                if ( Pos('counter', wsName) > 0 )
                  or ( Pos('image', wsName) > 0 )
                  or ( Pos('picture', wsName) > 0 )
                  or ( Pos('banner', wsName) > 0 )
                then
                  exit;
              end;
            end;
            Result := True;
            exit;
          end;
        end;
      end;
    end;

    Result := BinaryAutodetect;

  end;
end;

{------------------------------------------------------------------------------}

class function TfraHtmlText.SetNodeImageIndex(Node: TTreeNodeInfo;
  mp: TElMessagePart): Boolean;
begin
  Result := False;
  if (Node=nil) then
    exit;
  Result := True;
  Node.ImageIndex := 13;
  Node.SelectedIndex := 13;
end;

{------------------------------------------------------------------------------}

{$IFDEF _HTML_IE_}
procedure TfraHtmlText.CheckComplete;
var
  k: Integer;
  Msg: TMsg;
const
  iLimit = 10000-1;
begin
  k := 0;
  while (k<iLimit) and
    (WebBrowser.ReadyState = READYSTATE_LOADING)
  do
  begin
    //inc(k);
    while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
    begin
      if Msg.Message <> WM_QUIT then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end;
  end;
  //k := 0;
end;

{------------------------------------------------------------------------------}

procedure TfraHtmlText.ActivateDocument(bGoToBlankPage: Boolean = False);
var
  vURL, vFlags, vTargetFrameName, vPostData, vHeaders: OleVariant;
begin
  if bGoToBlankPage or (not Assigned(WebBrowser.Document)) then
  begin
    vURL := 'about:blank';
    vFlags := 0;
    vTargetFrameName := 0;
    vPostdata := 0;
    vHeaders := 0;
    WebBrowser.Navigate2(vURL, vFlags, vTargetFrameName, vPostData, vHeaders);
    CheckComplete;
  end;
end;
{$ENDIF IFDEF _HTML_IE_}
{------------------------------------------------------------------------------}

{$IFDEF _HTML_IE_}
procedure TfraHtmlText.UpdateHtml;
begin
{$IFDEF DEV_COMMENTS}
(*
procedure TEmbeddedWB.Print;
var
  vaIn, vaOut: Olevariant;
  HtmlText: string;
  Stream: IStream;
  Dummy: Int64;
  Psa: PSafeArray;
begin
  HtmlText := PrintOptions.HtmlHeader.Text;
  CreateStreamOnHGlobal(0, TRUE, Stream);
  Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
  Stream.Seek(0, STREAM_SEEK_SET, Dummy);
  SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
  TVarData(VaIn).VType := varArray or varByRef;
  SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
  InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);

// OLECMDEXECOPT constants
type
  OLECMDEXECOPT = TOleEnum;
const
  OLECMDEXECOPT_DODEFAULT = $00000000;
  OLECMDEXECOPT_PROMPTUSER = $00000001;
  OLECMDEXECOPT_DONTPROMPTUSER = $00000002;
  OLECMDEXECOPT_SHOWHELP = $00000003;

end;
*)
{$ENDIF IFDEF DEV_COMMENTS}
  if (fElMessagePart = nil) {$IFDEF _HTML_IE_}or (not WebBrowser.Visible){$ENDIF} then
    exit;

  {$IFDEF _HTML_IE_}
  if fHtmlStream = nil then
    fHtmlStream := TAnsiStringStream.Create;

  WebBrowser.Stop;
  CheckComplete;

  if (not cbShowHtml.Checked) then
  begin
    ActivateDocument(True);
    WebBrowser.Visible := False;
    exit;
  end;
  WebBrowser.Visible := True;

  fHtmlStream.AnsiData := Memo.Text;

  ActivateDocument;

  WebBrowser.Stop;
  if not Assigned(WebBrowser.Document) then
    exit;

  if IpStream = nil then
    IpStream := WebBrowser.Document as IPersistStreamInit;
  IpStream.Load(TStreamAdapter.Create(fHtmlStream));
  IpStream := nil;

  CheckComplete;
  {$ENDIF IFDEF _HTML_IE_}
end;
{$ENDIF IFDEF _HTML_IE_}
{------------------------------------------------------------------------------}


procedure TfraHtmlText.BeforeRemoveParent;
begin
  inherited;
  if (fElMessagePart = nil) {$IFDEF _HTML_IE_}or (not WebBrowser.Visible){$ENDIF} then
    exit;
  {$IFDEF _HTML_IE_}
  Screen.Cursor := crHourGlass;
  try
    Timer.Enabled := False;
    WebBrowser.Stop;
    CheckComplete;
    ActivateDocument(True);
    CheckComplete;
  finally
    Screen.Cursor := crDefault;
  end;
  {$ENDIF IFDEF _HTML_IE_}
end;

{------------------------------------------------------------------------------}
procedure TfraHtmlText.Init(mp: TElMessagePart; TagInfo: TTagInfo; Node: TTreeNodeInfo; bShow: Boolean);
var
  ws: TWideString;
  Buffer: TBytes;
  BufferSize: Integer;
  {$IFNDEF DELPHI_NET}
  S: AnsiString;
  {$ENDIF}
begin
  inherited;
  if (mp = nil) or (not bShow) then
    exit;

  fModified := False;


  if mp.IsText then
  begin
    mp.GetText(ws);
    Memo.Text := ws;
  end
  else
  begin
    // Show Attached text file:
    // todo: selected encoding ...
    BufferSize := 0;
    mp.GetData(Buffer, BufferSize);
    {$IFDEF DELPHI_NET}
      Memo.Text := StringOf(Buffer);
    {$ELSE}
      GetStringOf(Buffer, S);
      Memo.Text := S;
    {$ENDIF IFDEF DELPHI_NET}
  end;

  fModified := False;

  {$IFDEF _HTML_IE_}
  Timer.Enabled := cbShowHtml.Checked;
  //UpdateHtml;
  {$ENDIF IFDEF _HTML_IE_}

end;

{------------------------------------------------------------------------------}

procedure TfraHtmlText.WriteHTMLCode(sm: TElCustomMemoryStream);
begin
  if (sm=nil) or (fElMessagePart = nil) then
    exit;
  WriteStringToStream(Memo.Text, sm);
end;

{------------------------------------------------------------------------------}

procedure TfraHtmlText.UpdateView;
begin
  inherited;
  Init(fElMessagePart, fTagInfo, fNode, True );
  PageControl.Invalidate;
  PageControl.ActivePage.Invalidate;
end;

{------------------------------------------------------------------------------}

procedure TfraHtmlText.cbShowHtmlClick(Sender: TObject);
begin
  {$IFDEF _HTML_IE_}
  //UpdateHtml;
  if cbShowHtml.Checked then
    WebBrowser.Visible := True;
  Timer.Enabled := True;//cbShowHtml.Checked;
  {$ENDIF IFDEF _HTML_IE_}
end;

{------------------------------------------------------------------------------}

constructor TfraHtmlText.Create(AOwner: TComponent);
begin
  inherited;
  PageControl.ActivePageIndex := 1;
  {$IFDEF _HTML_IE_}
    Timer := TTimer.Create(Self);
    Timer.Enabled := False;
    Timer.Interval := 1000;
    Timer.OnTimer := TimerTimer;

    WebBrowser := TWebBrowser.Create(Self);
    WebBrowser.Visible := False;
    WebBrowser.Align := alClient;
    WebBrowser.Offline := True;
    WebBrowser.TabStop := True;
    WebBrowser.StatusBar := False;
    WebBrowser.MenuBar := False;
    WebBrowser.AddressBar := False;
    WebBrowser.FullScreen := False;
    TabSheetHtml.InsertControl(WebBrowser);
  {$ELSE}
    //cbShowHtml.Enabled := False;
    TabSheetHtml.Free;
    TabSheetOptions.Free;
    TabSheetSource.Caption := 'Html Source';
  {$ENDIF}
end;

{------------------------------------------------------------------------------}

destructor TfraHtmlText.Destroy;
begin
  {$IFDEF _HTML_IE_}
  fHtmlStream.Free;
  try
    IpStream := nil;
  except
    Pointer(IpStream) := nil;
  end;
  {$ENDIF IFDEF _HTML_IE_}
  inherited;
end;

{------------------------------------------------------------------------------}
{$IFDEF _HTML_IE_}
procedure TfraHtmlText.TimerTimer(Sender: TObject);
begin
  Timer.Enabled := False;
  Screen.Cursor := crHourGlass;
  try
    UpdateHtml;
  finally
    Screen.Cursor := crDefault;
  end;
end;
{$ENDIF IFDEF _HTML_IE_}
{------------------------------------------------------------------------------}

procedure TfraHtmlText.MemoChange(Sender: TObject);
begin
  fModified := True;
end;

procedure TfraHtmlText.PageControlChanging(Sender: TObject;
  var AllowChange: Boolean);
begin
  {$IFDEF _HTML_IE_}
  if fModified and cbShowHtml.Checked and (not Timer.Enabled) then
  begin
    Timer.Enabled := True;
  end;
  {$ENDIF IFDEF _HTML_IE_}
end;

function TfraHtmlText.GetCaption: string;
begin
  Result := 'HTML Part';
end;

initialization
  TfraHtmlText.RegisterClass(TfraHtmlText);
end.

elmimeviewer_htmltext.pas - 源码说明

本页面展示了「著名的SecureBlackBox控件完整源码」中的 elmimeviewer_htmltext.pas 源码文件，采用 PAS 编程语言编写，共 509 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫开发者社区收录了大量与security component相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?