web.pas

Delphi编写的一个支持语法高亮显示和很多语言的文本编辑器

unit web;

{This unit encapsulates SHDocVw.dll and MSHTML.dll functionality by subclassing
TWebBrowser object as TWeb object

TWeb was designed for easy use of HTML display and editing capacity in
SuperMemo 2002 for Windows developed by SuperMemo R&D in Fall 2001.

SuperMemo 2002 implements HTML-based incremental reading in which extensive HTML
support is vital

Pieces of this units can be used by anyone in other Delphi applications that make
use of HTML WYSIWYG interfaces made open by Microsoft

Please send comments, questions, suggestions for improvements or bugs to:
bugs(AT)supermemo(.)com}

{IMPORTANT! you need to assign TWinControl(Web).Parent to make Web:TWeb visible}
{For example, putting TWeb on a panel:
   TheWeb:=TWeb.Create(Panel);
   TheWeb.TheParent:=Self; //Form parenting the panel
   TWinControl(TheWeb).Parent:=Panel;
   TWinControl(TheWeb).Align:=alClient;
   TheWeb.Tag:=1; //Set different Tag if more TWeb's placed in a form}

interface

uses SysUtils,WinTypes,
     ActiveX,MSHTMLEvents2,SHDocVw_TLB, MSHTML_TLB,
     IeConst,Classes,Forms,Graphics;

const
  CGID_MSHTML:TGUID='{DE4BA900-59CA-11CF-9592-444553540000}';
  IID_IOleCommandTarget:TGUID='{B722BCCB-4E68-101B-A2BC-00AA00404770}';
  CGID_WebBrowser:TGUID='{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
  FontScale=3;

var IEStr,LastHyperlink:string;
    ApplicationOnMessage:TMessageEvent; {set to Forms.Application.OnMessage when creating the main form}
    OnMessageCompNo:byte;

type TWeb=class(TWebBrowser)
          public
             Modified,ReadOnly,Extrinsic,SuperMemoMenu,_Filter:boolean;
             TheDoc:IHTMLDocument2; //MSHTML HTML Document 2 interface
             TheWind:IHTMLWindow2;
             DocCmd,WebCmd:IOleCommandTarget; //MSHTML IOLECommandTarget interface
             Editable:boolean;
             TheSlot,TheTextPosit:integer;
             LastClickX,LastClickY:integer;
             TheParent:TForm;
             ElWind:byte; {pointer reference error protection; to occlude ElementWindow.ElWind in SuperMemo}
             LoadedHTMLFile:string;
             procedure Clear;
             procedure Save;
             procedure SaveAs(DefaultName:string);
             function SaveFile(Filename:string):boolean;
             procedure Print;
             procedure SetState(Edit:boolean);
             procedure LoadFile(FileName:string);
             procedure StatusTextChange(Sender: TObject; const Text: WideString);
             procedure CommandStateChange(Sender: TObject; Command: Integer; Enable: WordBool);
             procedure BeforeNavigate2(Sender: TObject;const pDisp: IDispatch;
                 var URL: OleVariant;var Flags: OleVariant;var TargetFrameName:OleVariant;
                 var PostData: OleVariant;var Headers: OleVariant;var Cancel: WordBool);
             procedure NavigateComplete2(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
             constructor Create(Owner:TComponent); override;
             destructor Destroy; override;
             procedure SetFocus; override;
             function SourceText:string;
             procedure SetSelection(Start,Length:integer);
             function GetTextRange:IHtmlTxtRange;
             function SelStart:integer;
             function SelEnd:integer;
             function SelLength:integer;
             procedure SetBackgroundColor(Color:TColor);
             function GetBackgroundColor:TColor;
             procedure SetHTMLText(HTML:WideString);
             procedure WaitLoad(peek:boolean);
             function GetScrollTop:integer;
             procedure SetScrollTop(ScrollTop:integer);
             function GetHTMLSelection:WideString;
             procedure ClearSelection;
             procedure ReplaceSelection(HTML:string);
             procedure SetFont(AFont:TFont;SetFontMode:byte);
             function Text:string;
             procedure SetBorder(Border:boolean);
             procedure SetScrollBar(ScrollBar:boolean);
             procedure Undo;
             procedure GetFont(var AFont:TFont);
             procedure FontDialog;
             function  SpecialCommand(Cmd : Cardinal; PromptUser : boolean;
                       editModeOnly : boolean; bTriEditCommandGroup : boolean;
                       InputArgs : OleVariant) : HRESULT;
             procedure ToggleBullet;
             procedure ToggleNumbering;
             procedure Indent(Indent:boolean);
             procedure Align(IDM:integer);
             function SelText:string;
             procedure Paste;
             procedure Copy;
             procedure Cut;
             procedure Delete;
             procedure SelectAll;
             procedure SetText(HTML:string);
             procedure CompleteLoading;
             function CompNo:byte;
             function Visible:boolean;
             procedure Find;
             procedure Subscript;
             procedure Superscript;
             {end public}
          private
             OleInPlaceActiveObject: IOleInPlaceActiveObject;
             Events:TMSHTMLHTMLDocumentEvents;
             CtrlToBeProcessed,ShiftToBeProcessed:boolean;
             procedure SuperMemoMessageHandler(var Msg: TMsg; var Handled: Boolean);
             procedure OnMouseDown(Sender:TObject);
             procedure OnMouseUp(Sender:TObject);
             procedure OnMouseMove(Sender:TObject);
             procedure OnMouseOver(Sender:TObject);
             procedure OnMouseOut(Sender:TObject);
             function OnClick(Sender:TObject):WordBool;
             function OnSelectStart(Sender:TObject):WordBool;
             procedure OnFocusOut(Sender:TObject);
             procedure OnFocusIn(Sender:TObject);
             function OnContextMenu(Sender:TObject):WordBool;
             function OnKeyPress(Sender:TObject):WordBool;
             procedure OnKeyDown(Sender:TObject);
             procedure OnKeyUp(Sender:TObject);
             procedure ClickPoint(X,Y:integer);
             procedure DefineEvents;
             function HyperlinkClicked:boolean;
             function HrExecCommand(ucmdID: cardinal;
                       const pVarIn: OleVariant; var pVarOut: OleVariant; bPromptUser,
                       bTriEditCmdGroup: boolean): HResult;
             procedure ProcessLoadMessages;
             procedure SetBorderWidth;
             procedure ReassignKeyboardHandler(CompNo:byte;TurnOn:boolean);
            {end private}
          end;

implementation

uses WinProcs,Messages,Controls,Variants,Clipbrd;
     {Pieces of code specific to SuperMemo are marked as: SMSpecific:}
     {SMSpecific:}{These units are specific to SuperMemo}
{     const8,Basic,Dial,Files,Component,
     DBDat,Col,Option,LayoutMan,ElementWindow,Main;}

var PtrWGUID,PtrMGUID,PtrDGUID:PGUID;
    NULL:OleVariant;

constructor TWeb.Create(Owner:TComponent);
begin
  inherited Create(Owner);
  LoadedHTMLFile:='';
  OnBeforeNavigate2:=BeforeNavigate2;
  OnStatusTextChange:=StatusTextChange;
  OnCommandStateChange:=CommandStateChange;
  OnNavigateComplete2:=NavigateComplete2;
  TheDoc:=nil;
  DocCmd:=nil;
  WebCmd:=nil;
  Modified:=false;
  SuperMemoMenu:=true; {SMSpecific}
  LastClickX:=0;
  LastClickY:=0;
  ReadOnly:=false;
  CtrlToBeProcessed:=false;
  ShiftToBeProcessed:=false;
  Events:=nil;
end;

destructor TWeb.Destroy;
begin
  ReassignKeyboardHandler(Tag,false);
  inherited Destroy;
end;

procedure TWeb.SaveAs(DefaultName:string);
begin
  if TheDoc=nil then
     exit;
  TheDoc.ExecCommand('SaveAs',false,DefaultName);
  Modified:=false;
end;

procedure TWeb.Print;
begin
  ExecWB(OLECMDID_PRINT,OLECMDEXECOPT_PROMPTUSER,NULL,NULL);
end;

procedure TWeb.Save;
var
  sHTML:string;
  fsOut:TFileStream;
begin
  sHTML:=SourceText;
  fsOut:=TFileStream.Create(TheDoc.URL,fmCreate or fmShareExclusive);
  try
    fsOut.Write(pchar(sHTML)^, length(sHTML));
  finally
    fsOut.Free;
    Modified:=false;
  end;
end;

procedure TWeb.OnKeyUp(Sender:TObject);
begin {those empty handlers are needed for the keyboard and mouse to behave correctly with EventSink!}
  {nop}
end;

procedure TWeb.OnMouseMove(Sender:TObject);
begin
 {nop}
end;

procedure TWeb.OnMouseOver(Sender:TObject);
begin
  {nop}
end;

procedure TWeb.OnMouseOut(Sender:TObject);
begin
 {nop}
end;

function TWeb.OnClick(Sender:TObject):WordBool;
begin
  Result:=true;
end;

function TWeb.OnSelectStart(Sender:TObject):WordBool;
begin
  Result:=true;
end;

procedure TWeb.OnMouseUp(Sender:TObject);
begin
  {nop}
end;

procedure TWeb.Clear;
begin
  TheTextPosit:=0;
  SetHTMLText('');
end;

function TWeb.SelStart:integer;
var TextRange:IHtmlTxtRange;
begin
  Result:=0;
  TextRange:=GetTextRange;
  if TextRange=nil then
     exit;
//  Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
end;

function TWeb.SelEnd:integer;
var TextRange:IHtmlTxtRange;
begin
  Result:=0;
  TextRange:=GetTextRange;
  if TextRange=nil then
     exit;
//  Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
end;

function TWeb.SelLength:integer;
begin
  Result:=SelEnd-SelStart;
end;

function TWeb.GetScrollTop:integer;
var FocusElement:IHTMLElement2;
begin
  Result:=0;
  try
     if TheDoc=nil then
        exit;
     FocusElement:=TheDoc.ActiveElement as IHTMLElement2;
     if FocusElement=nil then
        exit;
     Result:=FocusElement.ScrollTop;
  except
//    on E:Exception do EError('Cannot get scroll top position',E);
    end;
end;

function TWeb.GetHTMLSelection:WideString;
var TextRange:IHtmlTxtRange;
begin
  Result:='';
  TextRange:=GetTextRange;
  if TextRange=nil then
     exit;
  Result:=TextRange.HTMLText;
end;

procedure TWeb.ClearSelection;
begin
  if TheDoc=nil then
     exit;
  TheDoc.Selection.Clear;
  Modified:=true;
end;

procedure TWeb.ReplaceSelection(HTML:string);
var TextRange:IHtmlTxtRange;
begin
  try
     TextRange:=GetTextRange;
     if TextRange=nil then
        exit;
     TextRange.PasteHTML(HTML); {Warning! pasting relative paths will result in conversion to absolute paths!}
     Modified:=true;
  except
   on E:Exception do begin
//      ShortenString(HTML,80);
//      EError('Error pasting HTML'+nl+
//      'Microsoft HTML refuses to paste this string:'+nl+
//      HTML+nl,E);
      end;
   end;
end;

procedure TWeb.SetFont(AFont:TFont;SetFontMode:byte);
begin
end;

procedure TWeb.SetBorder(Border:boolean);
begin
  if TheDoc=nil then
     exit;
  if TheDoc.body=nil then
     exit;
  if not Border then begin
     if not Editable then begin
        TheDoc.body.style.borderStyle:='none';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='white';
        end;
     if Editable then begin
        TheDoc.body.style.borderStyle:='none';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='blue';
        end;
     end;
  if Border then begin
     if not Editable then begin
        TheDoc.body.style.borderStyle:='solid';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='silver';
        end;
     if Editable then begin
        TheDoc.body.style.borderStyle:='solid';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='blue';
        end;
     end;
end;

procedure TWeb.SetScrollBar(ScrollBar:boolean);
begin
  if TheDoc=nil then
     exit;
  if TheDoc.body=nil then
     exit;
  if ScrollBar then {values of "hidden" and "visible" lock PgUp and PgDn!}
     TheDoc.body.style.overflow:='scroll'
  else
     TheDoc.body.style.overflow:='auto';
end;

procedure TWeb.Undo;
begin
  if TheDoc=nil then
     exit;
  TheDoc.ExecCommand('Undo',false,0);
  Modified:=true;
end;

procedure TWeb.FontDialog;
begin
  SpecialCommand(IDM_FONT,True,True,False,Null);
  Modified:=true;
end;

function TWeb.SpecialCommand(Cmd:Cardinal;PromptUser:boolean;
                              editModeOnly:boolean;bTriEditCommandGroup:boolean;
                              InputArgs:OleVariant):HRESULT;
begin
  Result:=HrExecCommand(Cmd,null,InputArgs,promptUser,bTriEditCommandGroup);
end;

function TWeb.HrExecCommand(ucmdID: cardinal;
  const pVarIn: OleVariant; var pVarOut: OleVariant; bPromptUser,
  bTriEditCmdGroup: boolean): HResult;
var dwCmdOpt:DWORD;
begin
   result := S_OK;
   if DocCmd = nil then
      Exit;
   if (bPromptUser) then
      dwCmdOpt := MSOCMDEXECOPT_PROMPTUSER
   else
      dwCmdOpt := MSOCMDEXECOPT_DONTPROMPTUSER;
   if (bTriEditCmdGroup) then
      result := DocCmd.Exec(@GUID_TriEditCommandGroup,ucmdID,dwCmdOpt,pVarIn,pVarOut)
   else
      result := DocCmd.Exec(@CMDSETID_Forms3,ucmdID,dwCmdOpt,pVarIn,pVarOut);
end;

procedure TWeb.ToggleBullet;
begin
  if TheDoc=nil then
     exit;
  SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
  Modified:=true;
end;

procedure TWeb.ToggleNumbering;
begin
  if TheDoc=nil then
     exit;
  SpecialCommand(IDM_ORDERLIST,false,true,false,Null);
  Modified:=true;
end;

procedure TWeb.Align(IDM:integer);
begin
  if TheDoc=nil then
     exit;
  SpecialCommand(IDM,false,true,false,Null);
  Modified:=true;
end;

procedure TWeb.SetBackgroundColor(Color:TColor);
begin
  if TheDoc=nil then
     exit;
  TheDoc.ExecCommand('BackColor',false,Color);
  Modified:=true;
end;

function TWeb.SelText:string;
var TextRange:IHtmlTxtRange;
begin
  Result:='';
  TextRange:=GetTextRange;
  if TextRange=nil then
     exit;
  Result:=TextRange.text;
end;

procedure TWeb.Indent(Indent:boolean);
begin
  if TheDoc=nil then
     exit;
  if Indent then
     TheDoc.ExecCommand('Indent',false,0)
  else
     TheDoc.ExecCommand('Outdent',false,0);
  Modified:=true;
end;