web.pas

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

procedure TWeb.BeforeNavigate2(Sender: TObject;
   const pDisp: IDispatch;var URL: OleVariant;var Flags: OleVariant;var TargetFrameName:OleVariant;var PostData: OleVariant;
   var Headers: OleVariant;var Cancel: WordBool);
begin
{  if SuperMemoURL(URL) then begin {cancel the link if it uses an internal SuperMemo protocol}{SMSpecific}
{     Cancel:=true;
     LastHyperlink:='';
     exit;
     end;}
end;

procedure TWeb.SelectAll;
begin
//  SetSelection(0,MaxTextLength);
end;

procedure TWeb.NavigateComplete2(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
begin
  CompleteLoading;
end;

procedure TWeb.CompleteLoading;
begin
  Waitload(false); {used only to set up interface variables}
  SetBorderWidth;
  if ReadOnly then
     exit;
  if TheDoc=nil then
     exit;
  DefineEvents;
  {do not use Modified:=false here as navigation might go from an edited page to a hyperlinked page}
end;

procedure TWeb.SetHTMLText(Html:WideString); {after this command, Copy and Paste will not work}
var V:OleVariant;
begin
   try
      Stop;
      V:=Document;
      V.Open;
      V.Clear;
      V.Write(Html);
      V.Close;
      Modified:=true;
   except
//      on E:Exception do EError('Error setting HTML text',E);
     end;
end;

function TWeb.CompNo:byte;
begin
  Result:=byte(Tag);
end;

function TWeb.Visible;
begin
  Result:=true;
//  Result:=TWinControl(ElementWindow.ElWind.Objects[CompNo]).Visible;
end;

function TWeb.GetBackgroundColor:TColor;
var Background:OleVariant;
    vt:TVarType;
begin
  Result:=clWindow;
  try
     if TheDoc=nil then
        exit;
     if not Visible then {SMSpecific:}{to avoid errors on Ctrl+T before Show Answer}{Nov 8, 2001}
        exit;
     Background:=TheDoc.queryCommandValue('BackColor');
     vt:=varType(Background);
     if vt<>varNull then
        Result:=Background;
  except
//    on E:Exception do EError('Error retrieving background color',E);
    end;
end;

procedure TWeb.GetFont(var AFont:TFont);
var FontName,FontSize,FontColor:OleVariant;
    vt:TVarType;
begin
  try
     if TheDoc=nil then
        exit;
     {name}
     FontName:=TheDoc.queryCommandValue('FontName');
     vt:=varType(FontName);
     if vt<>varNull then
        AFont.Name:=FontName
     else
//        AFont.Name:=Database.DefaultFont.Name;
     {size}
     FontSize:=TheDoc.queryCommandValue('FontSize');
     vt:=varType(FontSize);
     if vt<>varNull then
        AFont.Size:=FontSize*FontScale
     else
//        AFont.Size:=Database.DefaultFont.Size;
     {color}
     FontColor:=TheDoc.queryCommandValue('ForeColor');
     vt:=varType(FontColor);
     if vt<>varNull then
        AFont.Color:=FontColor
     else
//        AFont.Color:=Database.DefaultFont.Color;
     {style}
     AFont.Style:=[];
     {bold}
     if TheDoc.queryCommandValue('Bold') then
        AFont.Style:=AFont.Style+[fsBold];
     {italic}
     if TheDoc.queryCommandValue('Italic') then
        AFont.Style:=AFont.Style+[fsItalic];
     {underline}
     if TheDoc.queryCommandValue('Underline') then
        AFont.Style:=AFont.Style+[fsUnderline];
  except
//    on E:Exception do EError('Error detecing HTML font',E);
    end;
end;

procedure TWeb.Find;
const HTMLID_FIND=1;
var vaIn,vaOut:OleVariant;
begin
  if WebCmd=nil then
     exit;
  WebCmd.Exec(PtrWGUID,HTMLID_FIND,0,vaIn,vaOut); {this command is not guaranteed to work in future versions of IE!}
end;

function TWeb.OnKeyPress(Sender:TObject):WordBool;
begin {must be defined empty for the keyboard to work correctly}
  Modified:=true;
  Result:=true;
end;

function TWeb.OnContextMenu(Sender:TObject):WordBool;
var APoint:TPoint;
begin
  Result:=true;
{  if AccessMode<amFull then
     exit;
  if SM8Main.IsSimplified then
     exit;
  if not SuperMemoMenu then
     exit;
  Result:=false;
  if TheParent<>ElementWindow.ElWind then
     exit;
  if TheDoc=nil then
     exit;
  if TheDoc.body=nil then
     exit;
  if Extrinsic then
     exit;
  if ReadOnly then
     exit;
  if TheWind=nil then
     exit;
  if TheWind.Event=nil then
     exit;}
  GetCursorPos(APoint);
//  ElementWindow.ElWind.CurrentComponent:=CompNo;
//  ElementWindow.ElWind.ComponentMenu.PopUp(APoint.X,APoint.Y);
end;

procedure TWeb.SetText(HTML:string);
begin
  if (TheDoc=nil)or(TheDoc.body=nil) then
     SetHTMLText(HTML)
  else
     TheDoc.body.innerHTML:=HTML;
end;

procedure TWeb.DefineEvents;
begin
//  if IEVer<5.5 then {if Internet Explorer older than 5.5 then ignore events}
 {    exit;
  if Events<>nil then
     Events.Free;
  Events:=TMSHTMLHTMLDocumentEvents.Create(Self);
  Events.Connect(IUnknown(Document));
  Events.OnMouseDown:=OnMouseDown;
  Events.OnMouseUp:=OnMouseUp;
  Events.OnMouseMove:=OnMouseMove;
  Events.OnMouseOver:=OnMouseOver;
  Events.OnMouseOut:=OnMouseOut;
  Events.OnClick:=OnClick;
  Events.OnSelectStart:=OnSelectStart;
  Events.OnKeyPress:=OnKeyPress;
  Events.OnKeyDown:=OnKeyDown;
  Events.OnKeyUp:=OnKeyUp;
  Events.OnContextMenu:=OnContextMenu;
  Events.OnFocusOut:=OnFocusOut;
  Events.OnFocusIn:=OnFocusIn;}
end;

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

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

procedure TWeb.Cut;
begin
  Copy;
  Delete;
end;

procedure TWeb.SetFocus;
begin
  try
    if TheDoc=nil then
       exit;
    SendMessage(Handle,wm_Activate,1,0);
    if TheWind<>nil then
       TheWind.Focus; {TheWind.Focus must come before TWeb.SetFocus}
    if TheParent.Visible then {Parenting window hosting web browser}
       if Visible then
          if CanFocus then
             inherited SetFocus; {must come AFTER TheWind.Focus}
  except
//    on E:Exception do EError('Error setting focus on HTML component',E);
    end;
end;

function TWeb.HyperlinkClicked:boolean;
var Element:IHTMLElement;
begin
  Result:=false;
  LastHyperlink:='';
  if TheWind.Event=nil then
     exit;
  Element:=TheWind.Event.srcElement;
  repeat
    if Element.tagName='A' then begin
       LastHyperlink:=Element.getAttribute('href',0);
       if LastHyperlink<>'' then begin
          Result:=TheWind.Event.Button=1; {Button=1 is the left mouse button}
          exit;
          end;
       end;
    if Element<>nil then
       Element:=Element.ParentElement;
    until Element=nil;
end;

procedure TWeb.SetScrollTop(ScrollTop:integer);
begin
  if TheDoc=nil then
     exit;
  if TheWind=nil then
     exit;
  TheWind.scrollTo(0,ScrollTop);
end;

procedure TWeb.Subscript;
begin
  if TheDoc=nil then
     exit;
  TheDoc.execCommand('Subscript',False,0);
  Modified:=true;
end;

procedure TWeb.Superscript;
begin
  if TheDoc=nil then
     exit;
  TheDoc.execCommand('Superscript',False,0);
  Modified:=true;
end;

procedure TWeb.ProcessLoadMessages;
var msg:TMsg;
    OldElementNo:integer;
    MessageQueue:array of TMsg;
    m:integer;
begin
//  OldElementNo:=ElementWindow.ElWind.TheElement;
  while PeekMessage(msg,0,wm_KeyFirst,wm_KeyLast,pm_Remove) do; {remove keyboard input first}
  while PeekMessage(msg,0,wm_MouseFirst,wm_MouseLast,pm_Remove) do; {remove mouse input}
  while PeekMessage(msg,0,wm_Close,wm_Close,pm_Remove) do; {disallow closing the application}
  while PeekMessage(msg,0,wm_ActivateApp,wm_ActivateApp,pm_Remove) do; {disallow activating the application}
//  while PeekMessage(msg,0,wm_User,cm_LastUserMessage,pm_Remove) do begin
        SetLength(MessageQueue,length(MessageQueue)+1);
        MessageQueue[length(MessageQueue)-1]:=msg;
        end;
//  forms.Application.ProcessMessages; {process messages needed to complete navigation}
{  for m:=1 to length(MessageQueue) do begin
      msg:=MessageQueue[m-1];
      PostMessage(msg.hwnd,msg.message,msg.wParam,msg.lParam);
      end;}
//  if ElementWindow.ElWind.TheElement<>OldElementNo then
//     Error('Element changed while loading HTML'+nl+
//           'Loading: '+ElementStr(OldElementNo)+nl+
 //          'Changed to: '+ElementStr(ElementWindow.ElWind.TheElement));
//end;

function TWeb.SaveFile(Filename:string):boolean;
var Source:string;
begin
  Result:=false;
  try
     Modified:=false;
     Source:=SourceText;
     if pos('&#',Source)=0 then
        if pos('<',Source)=0 then
           if pos('>',Source)=0 then begin
              Result:=false; {do not save plain text into the file}
              exit;
              end;
//     WriteStringToTXTFile(FileName,Source);
     Result:=true;
  except
//    on Exception do Error('Error writing to "'+Filename+'"');
    end;
end;

function TWeb.SourceText:string;
var WS:WideString;
    ch:WideChar;
    n:integer;
    w:word;
    s:string;
begin
  Result:='';
  if TheDoc=nil then
     exit;
  WS:=TheDoc.body.innerHTML;
  for n:=1 to length(WS) do begin
      ch:=WS[n];
      w:=word(ch);
      if w>255 then begin
         s:=IntToStr(w);
         s:='&#'+s+';';
         end
      else
         s:=ch;
      Result:=Result+s;
      end;
end;

function TWeb.Text:string;
var WS:WideString;
    ch:WideChar;
    n:integer;
    w:word;
    s:string;
begin
  Result:='';
  if TheDoc=nil then
     exit;
  WS:=TheDoc.body.innerText;
  for n:=1 to length(WS) do begin
      ch:=WS[n];
      w:=word(ch);
      if w>255 then begin
         w:=(w mod 256)+48;
         s:=IntToStr(w);
         s:=char(w);
         end
      else
         s:=ch;
      Result:=Result+s;
      end;
end;

procedure TWeb.ClickPoint(X,Y:integer);
var TextRange:IHtmlTxtRange;
begin
  try
     TextRange:=GetTextRange;
     if TextRange=nil then
        exit;
     TextRange.MoveToPoint(X,Y);
     TextRange.Select;
  except
//    on E:Exception do EError('Error processing mouse click',E);
    end;
end;

procedure TWeb.WaitLoad(peek:boolean);
begin
  try
     TheDoc:=Document as IHTMLDocument2;
     while TheDoc=nil do begin
        if peek then
           ProcessLoadMessages
        else
           exit;
        TheDoc:=Document as IHTMLDocument2;
        end;

     repeat
        ControlInterface.QueryInterface(IID_IOleCommandTarget,WebCmd);
        until WebCmd<>nil;

     repeat
        TheDoc.QueryInterface(IOleCommandTarget,DocCmd);
        until DocCmd<>nil;

     repeat
        TheWind:=TheDoc.parentWindow;
        until TheWind<>nil;

     while (TheDoc=nil)or((theDoc.ReadyState<>'complete')and(theDoc.ReadyState<>'interactive')) do begin
        {remove messages that should not be processed while the element is loading}
        {TheDoc can become nil when switching applications!}
        if TheDoc=nil then
           MessageBeep(0); {this beep is sounded while page is loading while SuperMemo is no longer in forefront}
        if peek then
           ProcessLoadMessages
        else
           exit;
        end;

  except
//       on E:Exception do EError('Error loading the document',E);
    end;
end;

procedure TWeb.SetSelection(Start,Length:integer);
var TextRange:IHtmlTxtRange;
begin
  try
     if TheDoc=nil then
        exit;
     TheDoc.Selection.Empty;
     TextRange:=GetTextRange;
     if TextRange=nil then
        exit;
     TextRange.collapse(true);
//     l:=TextRange.moveEnd('character',Start+Length);
//     l:=TextRange.moveStart('character',Start);
     TextRange.select;
  except
//    on E:Exception do EError('Error setting HTML selection'+nl+
//                             'Start='+IntToStr(Start)+nl+
 //                            'Length='+IntToStr(Length),E);
    end;
end;

procedure TWeb.SuperMemoMessageHandler(var Msg: TMsg; var Handled: Boolean);
{this message handler is vital to enable accelerators, Del, Backspace and other keys}
var iOIPAO: IOleInPlaceActiveObject;
    Dispatch: IDispatch;
begin
  Handled:=false;
  if msg.message=wm_SysChar then begin
//     SendMessage(ElementWindow.ElWind.Handle,Msg.message,Msg.wparam,Msg.lParam); {Nov 17, 2001}{to enable the main menu}
     Handled:=true;