首页 > 其他分享 >TEditWebBrowser 组件

TEditWebBrowser 组件

时间：2022-09-19 23:14:26浏览次数：73  
标签：begin end TEditWebBrowser self 组件 EditWebBrowsers procedure

继承TWebBrowser组件编写的组件：TEditWebBrowser，改写了原Mouse、Keyboard事件和OnEnter、OnExit事件。改写了TWebBrowser的焦点设置获取方法。
超强的Edit功能，完全替代TRichEdit组件，可以更方便的插入图片和表格。

unit EditWebBrowser;
//////////
//    制作：xcoming
//    版本：2005-8-30
//    联系：[email protected]
//////////
interface

uses
  SysUtils, Classes, Controls, OleCtrls, SHDocVw,Consts,
  Messages,Forms,windows,ActiveX,typinfo,MSHTML;

const
  IID_IOleCommandTarget:TGUID='{B722BCCB-4E68-101B-A2BC-00AA00404770}';

type
  TMouseDownEvent=procedure(Sender:Tobject;Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
  TMouseUpEvent=procedure(Sender:Tobject;Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
  TMouseMoveEvent=procedure(Sender:Tobject;Shift:TShiftState;x,y:integer) of object;
  TEnterEvent=procedure(Sender:Tobject) of object;
  TExitEvent=procedure(Sender:Tobject) of object;

  TDblClickEvent=procedure(Sender:Tobject;Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;

  TKeyDownEvent=procedure(Sender:Tobject;Shift:TShiftState;Key:word) of object;
  TKeyUpEvent=procedure(Sender:Tobject;Shift:TShiftState;Key:word) of object;

  TEditWebBrowser = class(TWebBrowser)
  private
    { Private declarations }
    FParentWinControl:TWinControl;
    FApplication:TApplication;
    FOnMouseDown:TMouseDownEvent;
    FOnMouseUp:TMouseUpEvent;
    FOnMouseMove:TMouseMoveEvent;
    FOnEnter:TEnterEvent;
    FOnExit:TExitEvent;
    FOnDblClick:TDblClickEvent;

    FOnKeyDown:TKeyDownEvent;
    FOnKeyUp:TKeyUpEvent;

    FFocused:boolean;
    FisShowSelfPopupMenu:boolean;
    FWantReturns:boolean;
    FVisible:boolean;

    FShiftFoceed,FCtrlFoceed:boolean;
    FReadOnly:boolean;
    FScrollbar:boolean;

    procedure OnMyMessage(var Msg:TMsg;var Handled:Boolean);
    function GetPoint(C:TComponent;p:TPoint):TPoint;

    procedure DoMouseDown(Button:TMouseButton;Shift:TShiftState;x,y:integer);
    procedure DoMouseUp(Button:TMouseButton;Shift:TShiftState;x,y:integer);
    procedure DoMouseMove(Shift:TShiftState;x,y:integer);
    procedure DoDblClick(Button:TMouseButton;Shift:TShiftState;x,y:integer);

    procedure DoKeyDown(Shift:TShiftState;Key:word);
    procedure DoKeyUp(Shift:TShiftState;Key:word);

    function GetInnerHTML:string;
    function GetInnerText:string;
    procedure SetisShowSelfPopupMenu(v:boolean);
    procedure SetWantReturns(v:boolean);
    procedure SetReadOnly(v:boolean);

    function GetScrollTop:integer;
    function GetScrollHeight:integer;
    function GetScrollLeft:integer;
    function GetScrollWidth:integer;
    function GetDocument:IHTMLDocument2;
    function GetWindow:IHTMLWindow2;
    function GetDocCMD:IOleCommandTarget;

    procedure SetScrollbar(v:boolean);
    function GetSelText():string;
    procedure SetSelText(s:string);
    function GetSelHTML():string;
    procedure SetSelHTML(s:string);

    procedure SetVisible(v:boolean);

    procedure DoEnter;
    procedure DoExit;
  protected

  public
    { Public declarations }
    constructor Create(Owner:TComponent);override;
    destructor Destroy;override;
    property Focused:boolean read FFocused;
    property InnerHTML:String read GetInnerHTML;
    property InnerText:String read GetInnerText;
    property ScrollTop:integer read GetScrollTop;
    property ScrollHeight:integer read GetScrollHeight;
    property ScrollLeft:integer read GetScrollLeft;
    property ScrollWidth:integer read GetScrollWidth;
    property Doc:IHTMLDocument2 read GetDocument;
    property Win:IHTMLWindow2 read GetWindow;
    property DocCMD:IOleCommandTarget read GetDocCMD;
    property Scrollbar:boolean read FScrollbar write SetScrollbar;
    property SelText:string read GetSelText write SetSelText;
    property SelHTML:string read GetSelHTML write SetSelHTML;

    procedure SetFocus;
    procedure WriteHTML(HTML:string);
    procedure AppendHTML(HTML:string);
    procedure Clear;
    procedure Print(isPrintView:boolean=true);
    procedure PrintPageSetup;
    procedure Copy;
    procedure Cut;
    procedure Paste;
    procedure SelectAll;
    procedure SaveAs(FileName:string='blank.htm');
    procedure ScrollTo(x,y:integer);
    procedure SetMargin(top,bottom,left,right:integer);

    procedure SetSelection(Start,Length:integer);
  published
    { Published declarations }
    property OnMouseDown:TMouseDownEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp:TMouseUpEvent read FOnMouseUp write FOnMouseUp;
    property OnMouseMove:TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnEnter:TEnterEvent read FOnEnter write FOnEnter;
    property OnExit:TExitEvent read FOnExit write FOnExit;
    property OnDblClick:TDblClickEvent read FOnDblClick write FOnDblClick;

    property OnKeyUp:TKeyUpEvent read FOnKeyUp write FOnKeyUp;
    property OnKeyDown:TKeyDownEvent read FOnKeyDown write FOnKeyDown;
    property isShowSelfPopupMenu:boolean read FisShowSelfPopupMenu write SetisShowSelfPopupMenu;
    property WantReturns:boolean read FWantReturns write SetWantReturns;


    property ReadOnly:boolean read FReadOnly write SetReadOnly;
    property Visible:boolean read FVisible write SetVisible;

  end;

procedure Register;

implementation

type TEditWebBrowsers=class(TComponent)
  private
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;override;
  public
    EditWebBrowsers:array of TEditWebBrowser;
    procedure OnMyMessage(var Msg:TMsg;var Handled:Boolean);
end;

var EditWebBrowsers:TEditWebBrowsers=nil;

procedure TEditWebBrowsers.OnMyMessage(var Msg:TMsg;var Handled:Boolean);
var i:integer;
begin
  try
    for i:=0 to length(self.EditWebBrowsers) do
      if self.EditWebBrowsers[i]<>nil then
        if not self.EditWebBrowsers[i].OleObject.document.hasfocus then
          if self.EditWebBrowsers[i].FFocused then begin
          self.EditWebBrowsers[i].DoExit; break;
          end;
  except end;
  try
    for i:=0 to length(self.EditWebBrowsers) do
      if self.EditWebBrowsers[i]<>nil then
        if self.EditWebBrowsers[i].OleObject.document.hasfocus then
          if not self.EditWebBrowsers[i].FFocused then begin
          self.EditWebBrowsers[i].DoEnter; break;
          end;
  except end; 
 try
   for i:=0 to length(self.EditWebBrowsers) do
      if self.EditWebBrowsers[i]<>nil then
       try self.EditWebBrowsers[i].OnMyMessage(Msg,Handled); except end;
  except end;
end;

constructor TEditWebBrowsers.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  Application.OnMessage:=OnMyMessage;
end;

destructor TEditWebBrowsers.Destroy;
begin
  Application.OnMessage:=nil;
end;

constructor TEditWebBrowser.Create(Owner:TComponent);
var i:integer; flag:boolean;
begin
  inherited Create(Owner);
  if not Assigned(self.Document) then self.Navigate('about:blank');
  self.SetReadOnly(false);
  FisShowSelfPopupMenu:=true;
  self.SetWantReturns(true);
  self.SetisShowSelfPopupMenu(false);
  self.FScrollbar:=true;
  self.FFocused:=false;
  self.FVisible:=true;
  flag:=false;
  try
   for i:=0 to length(EditWebBrowsers.EditWebBrowsers)-1 do
     if EditWebBrowsers.EditWebBrowsers[i]=nil then begin
       EditWebBrowsers.EditWebBrowsers[i]:=self;
       flag:=true;break;
     end;
  except end;
  if not flag then begin
    setLength(EditWebBrowsers.EditWebBrowsers
      ,length(EditWebBrowsers.EditWebBrowsers)+1);
    EditWebBrowsers.EditWebBrowsers
      [length(EditWebBrowsers.EditWebBrowsers)-1]:=self;
  end;
end;

procedure TEditWebBrowser.DoEnter;
begin 
  self.FFocused:=true;
  TWinControl(self).SetFocus;
  if self.Win<>nil then self.Win.focus;
  if Assigned(FOnEnter) then FOnEnter(self);
end;

procedure TEditWebBrowser.DoExit;
begin
  self.FFocused:=false;
  if self.OleObject.document.hasfocus then
    if self.Win<>nil then self.Win.blur;
  if Assigned(FOnExit) then FOnExit(self);
end;

function TEditWebBrowser.GetDocument:IHTMLDocument2;
begin
  result:=self.Document as IHTMLDocument2;
end;

function TEditWebBrowser.GetWindow:IHTMLWindow2;
var W:IHTMLWindow2;
begin
  repeat W:=self.Doc.parentWindow;
  until W<>nil;     result:=W;
end;

function TEditWebBrowser.GetDocCMD:IOleCommandTarget;
var DCMD:IOleCommandTarget;
begin
  repeat self.Doc.QueryInterface(IOleCommandTarget,DCMD);
  until DCMD<>nil;
  result:=DCMD;
end;

procedure TEditWebBrowser.SetReadOnly(v:boolean);
begin
  self.FReadOnly:=v;
  if self.FReadOnly then
    self.Doc.designMode:='off'
  else
    self.Doc.designMode:='on';
end;

procedure TEditWebBrowser.SetMargin(top,bottom,left,right:integer);
begin
  self.Doc.body.style.marginTop:=top;
  self.Doc.body.style.marginBottom:=bottom;
  self.Doc.body.style.marginLeft:=left;
  self.Doc.body.style.marginRight:=right;
end;

procedure TEditWebBrowser.ScrollTo(x,y:integer);
begin
  self.OleObject.document.parentwindow.scrollto(x,y);
end;

function TEditWebBrowser.GetScrollTop:integer;
begin
  result:=self.OleObject.document.body.scrollTop;
end;

function TEditWebBrowser.GetScrollHeight:integer;
begin
  result:=self.OleObject.document.body.scrollHeight;
end;

function TEditWebBrowser.GetScrollLeft:integer;
begin
  result:=self.OleObject.document.body.scrollLeft;
end;

function TEditWebBrowser.GetScrollWidth:integer;
begin
  result:=self.OleObject.document.body.scrollWidth;
end;

destructor TEditWebBrowser.Destroy;
var i:integer;
begin
  try
    for i:=0 to length(EditWebBrowsers.EditWebBrowsers)-1 do
      if EditWebBrowsers.EditWebBrowsers[i]=self then begin
        EditWebBrowsers.EditWebBrowsers[i]:=nil;
        break;
      end;
  except end;
  inherited Destroy;
end;

function TEditWebBrowser.GetInnerHTML:string;
begin
  result:=self.OleObject.document.All.item.innerhtml;
end;

function TEditWebBrowser.GetInnerText:string;
begin
  result:=self.OleObject.document.All.item.innerText;
end;

procedure TEditWebBrowser.WriteHTML(HTML:string);
begin
  self.OleObject.document.close();
  self.OleObject.document.clear();
  self.OleObject.document.write(HTML);
end;

procedure TEditWebBrowser.Clear;
begin
  self.OleObject.document.close();
  self.OleObject.document.clear();
  //本方法不能真正清除文档，最好是用：WriteHtml(' ')清除
end;

procedure TEditWebBrowser.SetScrollbar(v:boolean);
begin
  self.FScrollbar:=v;
  if v then self.Doc.body.style.overflow:='scroll'
  else self.Doc.body.style.overflow:='hidden'
end;

procedure TEditWebBrowser.AppendHTML(HTML:string);
begin
  self.OleObject.document.write(HTML);
end;

procedure TEditWebBrowser.SetFocus;
begin
  {注：设定某一个TEditWebBrowser的焦点时，如果当前的焦点正在另
  一个TEditWebBrowser上，则此时最好先使有焦点的TEditWebBrowser控件
  失去焦点。例如：
    EW1有焦点，要通过程序设置EW2的焦点，应该这样：
      EW1.Win.blur;
      EW2.SetFocus;
  }
  self.Win.focus;
end;

procedure TEditWebBrowser.Print(isPrintView:boolean=true);
begin
  if isPrintView then
    self.ExecWB(OLECMDID_PRINTPREVIEW,OLECMDEXECOPT_DODEFAULT)
  else
    self.ExecWB(OLECMDID_PRINT,OLECMDEXECOPT_DODEFAULT);
end;

procedure TEditWebBrowser.PrintPageSetup;
begin
  self.ExecWB(OLECMDID_PAGESETUP,OLECMDEXECOPT_DODEFAULT);
end;

procedure TEditWebBrowser.Copy;
begin
  self.ExecWB(OLECMDID_COPY,OLECMDEXECOPT_DODEFAULT);
end;

procedure TEditWebBrowser.Paste;
begin
  self.ExecWB(OLECMDID_PASTE,OLECMDEXECOPT_DODEFAULT);
end;

procedure TEditWebBrowser.SelectAll;
begin
  self.ExecWB(OLECMDID_SELECTALL,OLECMDEXECOPT_DODEFAULT);
end;

procedure TEditWebBrowser.Cut;
begin
  self.ExecWB(OLECMDID_CUT,OLECMDEXECOPT_DODEFAULT);
end;

procedure TEditWebBrowser.SaveAs(FileName:string='blank.htm');
begin
  self.Doc.execCommand('SaveAs',false,FileName);
end;

function TEditWebBrowser.GetPoint(C:TComponent;p:TPoint):TPoint;
var rsp:TPoint;
begin
  if C.Owner is TForm then begin
    rsp.X:=p.X-(C.Owner as TForm).Left;
    rsp.Y:=p.Y-(C.Owner as TForm).Top;
    rsp.X:=rsp.X-((C.Owner as TForm).Width-(C.Owner as TForm).ClientWidth) div 2;
    rsp.Y:=rsp.Y-((C.Owner as TForm).Height-(C.Owner as TForm).ClientHeight);
    result:=rsp;
  end else begin
    rsp.X:=p.X-GetOrdProp(C.Owner,'Left');
    rsp.Y:=p.Y-GetOrdProp(C.Owner,'Top');
    result:=self.GetPoint(C.Owner,rsp);
  end;
end;

procedure TEditWebBrowser.OnMyMessage(var Msg:TMsg;var Handled:Boolean);
var p:TPoint;ShiftState:TShiftState;Key:word;
  bKey:TKeyBoardState;
begin
  //GetCursorPos(p); 

  p.X:=Msg.pt.X-self.Left;  p.Y:=Msg.pt.Y-self.Top;
  p:=self.GetPoint(self,p);
  if (p.X>=0) and (p.X<=self.Width) and (p.Y>=0)
    and (p.Y<=self.Height) then begin
    if Msg.message=WM_RBUTTONDOWN then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      Handled:=not self.FisShowSelfPopupMenu;
      DoMouseDown(mbRight,ShiftState,p.X,p.Y);
    end else if Msg.message=WM_LBUTTONDOWN then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      DoMouseDown(mbLeft,ShiftState,p.X,p.Y);
    end else if Msg.message=WM_RBUTTONUP then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      Handled:=not self.FisShowSelfPopupMenu;
      DoMouseUp(mbRight,ShiftState,p.X,p.Y);
    end else if Msg.message=WM_LBUTTONUP then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      DoMouseUp(mbLeft,ShiftState,p.X,p.Y);
    end else if Msg.message=WM_MOUSEMOVE then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      DoMouseMove(ShiftState,p.X,p.Y);
    end else if Msg.message=WM_LBUTTONDBLCLK then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      DoDblClick(mbLeft,ShiftState,p.X,p.Y);
    end else if Msg.message=WM_RBUTTONDBLCLK then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      Handled:=not self.FisShowSelfPopupMenu;
      DoDblClick(mbRight,ShiftState,p.X,p.Y);
    end;
  end;

  if self.OleObject.document.hasfocus then begin
    if Msg.message=WM_KEYDOWN then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      Key:=Msg.wParam;
      if not self.FReadOnly then begin
        if Key=13 then begin
          if self.FWantReturns then begin
          if not (ssShift in ShiftState) then begin
          GetKeyboardState(bKey);
          bKey[VK_Shift]:=not bKey[VK_Shift];
          SetKeyboardState(bKey);
          self.FShiftFoceed:=true;
          end;
          end else begin
          if (ssCtrl in ShiftState) then begin
          self.FCtrlFoceed:=true;
          GetKeyboardState(bKey);
          bKey[VK_CONTROL]:=not bKey[VK_CONTROL];
          SetKeyboardState(bKey);
          if not (ssShift in ShiftState) then begin
          GetKeyboardState(bKey);
          bKey[VK_Shift]:=not bKey[VK_Shift];
          SetKeyboardState(bKey);
          self.FShiftFoceed:=true;
          end;
          end else Msg.wParam:=0;
          end;
        end;
      end;
      DoKeyDown(ShiftState,Key);
    end else if Msg.message=WM_KEYUP then begin
      ShiftState:=KeyDataToShiftState(Msg.wParam);
      Key:=Msg.wParam;
      if not self.FReadOnly then begin
        if Key=13 then begin
          if self.FShiftFoceed then begin
          GetKeyboardState(bKey);
          bKey[VK_Shift]:=not bKey[VK_Shift];
          SetKeyboardState(bKey);
          Msg.wParam:=0;
          self.FShiftFoceed:=false;
          end;
        end;
      end;
      if self.FCtrlFoceed then begin
        Include(ShiftState,ssCtrl);
        self.FCtrlFoceed:=false;
      end;
      DoKeyUp(ShiftState,Key);
    end;
  end;

  //TranslateMessage(Msg);
  //DispatchMessage(Msg);
end;

procedure TEditWebBrowser.DoMouseDown(Button:TMouseButton;Shift:TShiftState;x,y:integer);
begin
  if Assigned(FOnMouseDown) then FOnMouseDown(self,Button,Shift,x,y);
end;

procedure TEditWebBrowser.DoMouseUp(Button:TMouseButton;Shift:TShiftState;x,y:integer);
begin
  if Assigned(FOnMouseUp) then FOnMouseUp(self,Button,Shift,x,y);
end;

procedure TEditWebBrowser.DoMouseMove(Shift:TShiftState;x,y:integer);
begin
  if Assigned(FOnMouseMove) then FOnMouseMove(self,Shift,x,y);
end;

procedure TEditWebBrowser.DoDblClick(Button:TMouseButton;Shift:TShiftState;x,y:integer);
begin
  if Assigned(FOnDblClick) then FOnDblClick(self,Button,Shift,x,y);
end;

procedure TEditWebBrowser.DoKeyDown(Shift:TShiftState;Key:word);
begin
  if Assigned(FOnKeyDown) then FOnKeyDown(self,Shift,Key);
end;

procedure TEditWebBrowser.DoKeyUp(Shift:TShiftState;Key:word);
begin
  if Assigned(FOnKeyUp) then FOnKeyUp(self,Shift,Key);
end;

procedure TEditWebBrowser.SetisShowSelfPopupMenu(v:boolean);
begin
  self.FisShowSelfPopupMenu:=v;
end;

procedure TEditWebBrowser.SetWantReturns(v:boolean);
begin
  self.FWantReturns:=v;
end;

function TEditWebBrowser.GetSelText():string;
begin
  result:=(self.Doc.selection.createRange as IHtmlTxtRange).text;
end;

procedure TEditWebBrowser.SetSelText(s:string);
begin
  (self.Doc.selection.createRange as IHtmlTxtRange).text:=s;
end;

function TEditWebBrowser.GetSelHTML():string;
begin
  result:=(self.Doc.selection.createRange as IHtmlTxtRange).htmlText;
end;

procedure TEditWebBrowser.SetSelHTML(s:string);
begin
  (self.Doc.selection.createRange as IHtmlTxtRange).pasteHTML(s);
end;

procedure TEditWebBrowser.SetVisible(v:boolean);
begin
  self.FVisible:=v;
  TWinControl(self).Visible:=v;
end;

procedure TEditWebBrowser.SetSelection(Start,Length:integer);
var TextRange:IHtmlTxtRange;
begin
  self.Doc.selection.empty;
  TextRange:=self.Doc.selection.createRange as IHtmlTxtRange;
  TextRange.collapse(true);
  TextRange.moveEnd('character',Start+Length);
  TextRange.moveStart('character',Start);
  TextRange.select;
end;

procedure Register;
begin
  RegisterComponents('Internet', [TEditWebBrowser]);
end;

initialization
  try OleInitialize(nil); except end;
  EditWebBrowsers:=TEditWebBrowsers.Create(application);
finalization
  try OleUninitialize; except end;
  
end.

转自：http://www.2ccc.com/article.asp?articleid=2525

标签：begin,end,TEditWebBrowser,self,组件,EditWebBrowsers,procedure
From： https://www.cnblogs.com/tang-delphi/p/16709454.html

相关文章

  • 【Vue】Vue 组件交互（四）
    本例介绍Vue组件交互1、新建Vue项目参考：【Vue】Vue项目搭建（二）2、引入CSSindex页面引入bootstrap.css1<!DOCTYPEhtml>2<html>3<head>4<......
  • element ui / vue 表格组件
    ElementUI是一套基于VUE2.0的桌面端组件库，ElementUI提供了丰富的组件帮助开发人员快速构建功能强大、风格统一的页面。官网地址：http://element-cn.eleme.io/#/zh-CN在页......
  • 【vue3】element-plus组件国际化随时切换语言
    背景我们可以通过ui组件库来统一调整组件的语言设置，比如统一设置成中文或者英文步骤引入element-plus相关的语言包。这里使用中文通过el-config-provider组件进行配......
  • vue3组件的几种引入、注册、自动注册等
    全局组件的注册和引入全局组件注册components/index.js【方式一：先引入后注册】importBgImagefrom"@/components/global/web-background/bg-image.vue";importBa......
  • Vue 系统组件 <KeepAlive> 简介
    <KeepAlive>@说明：缓存被包裹的组件先看段动态绑定组件代码：<component:is="activeComponent"></component>在上例代码中，随着组件的动态切换，旧的组件会被删除，新的组件......
  • react-native 函数组件调用函数组件的方法
    xxxRef.current.你的方法()  ......
  • Vue 组件插槽
    默认插槽的定义与使用<!--组件test定义--><template><button><slot>提交</slot></button></template><!--父组件调用--><template>......
  • 29. Activity组件
    29.Activity组件29.1认识Activity应用画面→ActivityActivity是一个应用程序组件，提供一个屏幕，用户可以用来交互为了完成某项任务。Activity中所有操作都与用户密切相......
  • 30. Service组件
    30.Service组件30.1认识Service服务在后台默默地运行，是不可见的。30.2startService与生命周期新建一个Activity在清单文件中设置Activity3默认启动MyService.j......
  • 31. Receiver组件
    31.Receiver组件31.1认识Receiver广播：分为系统广播与用户自定义广播系统广播：开机广播、网络状态广播、蓝牙…31.2静态注册接收广播定义一个广播接收者package......

赞助商

阅读排行

网站主页关于我们联系我们网站地图

本网站内容转载自其他媒体，侵权联系[admin##ips99.com]。

Copyright © 2020-2023 IPS99 版权所有 IPS99