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,MSHTMLEvents,SHDocVw,MSHTML, 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 try if TheDoc=nil then exit; Modified:=true; case TSetFontMode(SetFontMode) of sfAll:begin SetFont(AFont,byte(sfName)); SetFont(AFont,byte(sfSize)); SetFont(AFont,byte(sfStyle)); SetFont(AFont,byte(sfColor)); SetFont(AFont,byte(sfCharset)); end; sfSize:TheDoc.ExecCommand('FontSize',false,AFont.Size div FontScale); sfColor:TheDoc.ExecCommand('ForeColor',false,AFont.Color); sfName:TheDoc.ExecCommand('FontName',false,AFont.Name); sfStyle:begin {bold} if TheDoc.queryCommandValue('Bold') then TheDoc.ExecCommand('Bold',false,true); if fsBold in AFont.Style then TheDoc.ExecCommand('Bold',false,true); {italic} if TheDoc.queryCommandValue('Italic') then TheDoc.ExecCommand('Italic',false,true); if fsItalic in AFont.Style then TheDoc.ExecCommand('Italic',false,true); {underline} if TheDoc.queryCommandValue('Underline') then TheDoc.ExecCommand('Underline',false,true); if fsUnderline in AFont.Style then TheDoc.ExecCommand('Underline',false,true); end; end; except on E:Exception do EError('Error setting HTML font',E); end; 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; 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} if TheParent<>ElementWindow.ElWind then exit; if TElWind(TheParent).GetState(CompNo)=stEdit then SetState(true) else SetState(false); 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; if TheParent<>ElementWindow.ElWind then exit; 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; exit; end; if not ((msg.message=wm_keydown)or(msg.message=wm_keyup)or(msg.message=wm_char)) then exit; if msg.wparam=ord('P') then begin if ShiftToBeProcessed then if CtrlToBeProcessed then begin {Block printing} msg.wparam:=0; CtrlToBeProcessed:=false; ShiftToBeProcessed:=false; Handled:=true; SM8Main.MIElementParametersClick(nil); exit; end; if CtrlToBeProcessed then begin {Block printing} msg.wparam:=0; CtrlToBeProcessed:=false; Handled:=true; Sm8Main.MIPlanClick(nil); {SMSpecific}{Open Plan with Ctrl+P} exit; end; end; if msg.wparam=ord('F') then begin if CtrlToBeProcessed then begin {Block searching} msg.wparam:=0; CtrlToBeProcessed:=false; Handled:=true; ElementWindow.ElWind.LockReadPointOnSearch:=true; Sm8Main.ActFindStringExecute(nil); {SMSpecific}{Search whole collection} exit; end; end; if msg.wparam=17 then {Ctrl key pressed} if msg.message=wm_keydown then begin CtrlToBeProcessed:=true; Handled:=true; exit; end; if msg.wparam=vk_Shift then if msg.message=wm_keydown then begin ShiftToBeProcessed:=true; Handled:=true; exit; end; CtrlToBeProcessed:=false; ShiftToBeProcessed:=false; if msg.wparam in [vk_Return,vk_Escape, {to ensure that Enter and shortcuts work} {vk_F3 cannot be used due to conflict with 'R'} vk_F4, {tasklist} {vk_F6 is handled in OnKeyDown} vk_F7, {read points} vk_F11, {random jump} vk_F12, {quick backup, recovery} vk_Up, {to handle Ctrl+Alt+Up} ord('1'), {Ctrl+Shift+1 for deHTMLize} {'A' cannot be listed due to conflict with Show Answer} {'D' cannot be listed due to conflict with Dismiss} ord('E'), {Ctrl+alt+E} ord('F'), {Ctrl+Shift+F} {'G' cannot be listed due to conflict with Cancel Grade} ord('H'), {Ctrl+Alt+H} ord('J'), {Ctrl+J} ord('K'), {Ctrl+Alt+K} {'M' cannot be listed due to conflict with Remember} ord('T'), {Ctrl+T} ord('U'), {Ctrl+Alt+U} ord('W') {Ctrl+W} ] then exit; if Msg.wParam in [vk_Back,vk_Delete] then Modified:=true; Handled:=(IsDialogMessage(Handle, Msg) = True); if (Handled) and (not Busy) then begin if OleInPlaceActiveObject = nil then begin Dispatch := Application; if Dispatch <> nil then begin Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO); if iOIPAO <> nil then OleInPlaceActiveObject := iOIPAO; end; end; if OleInPlaceActiveObject <> nil then if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and ((Msg.wParam=VK_BACK)or {do not include vk_Delete here!!!}{Nov 11, 2001} (Msg.wParam=VK_LEFT)or(Msg.wParam=VK_RIGHT)or (Msg.wParam=VK_Up)or (Msg.wParam=VK_Down)or (Msg.wParam=vk_Next)or(Msg.wParam=vk_Prior)) then {nop} else OleInPlaceActiveObject.TranslateAccelerator(Msg); end; end; procedure TWeb.SetBorderWidth; begin try if TheDoc=nil then exit; if TheParent<>ElementWindow.ElWind then exit; SetBorder(TElWind(TheParent).GetBorder(CompNo)); SetScrollBar(TElWind(TheParent).GetScrollBar(CompNo)); except on Exception do Error('Cannot set HTML border'); end; end; procedure TWeb.OnFocusIn(Sender:TObject); begin if Editable then ReassignKeyboardHandler(CompNo,true); {each TWeb has a unique handler which must be reassigned at SetFocus} end; procedure TWeb.ReassignKeyboardHandler(CompNo:byte;TurnOn:boolean); {assign HTML keyboard handler to HTML component; assign standard if TurnOn=false} var IsDefault:boolean; begin if TurnOn then if CompNo<>0 then begin Forms.Application.OnMessage:=SuperMemoMessageHandler; {each TWeb has a unique handler which must be reassigned at SetFocus} OnMessageCompNo:=CompNo; end; if not TurnOn then if CompNo=OnMessageCompNo then begin Forms.Application.OnMessage:=ApplicationOnMessage; OnMessageCompNo:=0; end; IsDefault:=OnMessageCompNo=0; if TheParent=ElementWindow.ElWind then begin ElementWindow.ElWind.Learn.Default:=IsDefault; ElementWindow.ElWind.ShowAnswer.Default:=IsDefault; ElementWindow.ElWind.Pass.Default:=IsDefault; ElementWindow.ElWind.NextRepetition.Default:=IsDefault; end; end; procedure TWeb.Copy; var TheRange:OleVariant; begin if TheDoc=nil then exit; TheDoc.ExecCommand('Copy',false,0); if Clipboard.AsText='' then begin if (TheDoc.Selection.type_='Text')or(TheDoc.Selection.type_='None') then TheRange:=TheDoc.Selection.CreateRange as IHtmlTxtRange else TheRange:=TheDoc.Selection.CreateRange as IHtmlControlRange; TheRange.execCommand('Copy'); end; end; procedure TWeb.StatusTextChange(Sender: TObject; const Text: WideString); begin SM8Main.ShowStatusText(Text); end; procedure TWeb.CommandStateChange(Sender: TObject; Command: Integer; Enable: WordBool); begin case Command of CSC_NAVIGATEBACK:if not Enable then Extrinsic:=false; {to make sure Back< does not execute TWeb.GoBack} CSC_NAVIGATEFORWARD:{nop}; end; end; procedure TWeb.SetState(Edit:boolean); begin try SetBorderWidth; if ReadOnly then exit; if IEVer<5.5 then exit; if TheDoc<>nil then begin if Edit then begin if TheDoc.body<>nil then begin TheDoc.body.setAttribute('contentEditable','true',0); SetFocus; SuperMemoMenu:=true; Editable:=true; end; end; if not Edit then begin if TheDoc.body<>nil then begin TheDoc.body.setAttribute('contentEditable','false',0); ReassignKeyboardHandler(CompNo,false); Editable:=false; end; end; end; except on E:Exception do EError('Error switching HTML editing state',E); end; end; procedure TWeb.OnMouseDown(Sender:TObject); var ScrollTop:integer; begin if HyperlinkClicked then if not Editable then begin SuperMemoMenu:=false; {SMSpecific} Extrinsic:=true; exit; end; TComponent(Sender).Tag:=CompNo; 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; if Editable then begin if TheParent=ElementWindow.ElWind then begin if not TheWind.Event.altKey then exit; ElementWindow.ElWind.SetState(CompNo,stDrag); end; SetState(true); {Parent not ElementWindow} SetFocus; exit; end; if not Editable then begin if TheWind.Event.button<>1 {mbLeft} then exit; if Width-TheWind.event.offsetX<VerticalScrollBarWidth+2 then {scrollbar click} exit; if Height-(TheWind.event.offsetY-GetScrollTop)<HorizontalScrollBarHeight+2 then {scrollbar click} exit; LastClickX:=TheWind.Event.X; LastClickY:=TheWind.Event.Y; ScrollTop:=GetScrollTop; if TheParent=ElementWindow.ElWind then ElementWindow.ElWind.FormMouseDown(Sender,mbLeft,[],LastClickX,LastClickY) {SMSpecific} else SetState(true); SetFocus; SetScrollTop(ScrollTop); ClickPoint(LastClickX,LastClickY); end; end; procedure TWeb.OnFocusOut(Sender:TObject); begin ReassignKeyboardHandler(CompNo,false); {each TWeb has a unique handler which must be cleared at Focus out} end; procedure TWeb.LoadFile(FileName:string); var OldWidth,OldHeight:integer; begin try Hourglass; OldHeight:=Height; OldWidth:=Width; Navigate(FileName); LoadedHTMLFile:=FileName; Width:=OldWidth; {due to a bug that sizes down HTML components on start}{Oct 15, 2001} Height:=OldHeight; TheDoc:=nil; if DocCmd<>nil then begin DocCmd._Release; DocCmd:=nil; end; Modified:=false; Extrinsic:=false; _Filter:=false; except on E:Exception do begin EError('Cannot load '+Filename,E); ElementWindow.ElWind.MustReloadComponents:=false; {otherwise wm_ActicateApp can loop} end; end; end; procedure TWeb.OnKeyDown(Sender:TObject); {SMSpecific: most of the codes used here are specific to SuperMemo} begin if TheWind=nil then exit; if TheWind.Event=nil then exit; if TheParent<>ElementWindow.ElWind then begin Modified:=true; exit; end; if not Editable then begin SendMessage(ElementWindow.ElWind.Handle,wm_KeyDown,TheWind.Event.KeyCode,0); exit; end; with TheWind.Event do begin if KeyCode=vk_Return then begin if (not CtrlKey) and (not ShiftKey) and (not AltKey) then if SelLength>0 then begin {SMSpecific} SetState(false); SendMessage(ElementWindow.ElWind.Handle,wm_KeyDown,TheWind.Event.KeyCode,0); exit; end; end; if KeyCode=vk_Delete then if CtrlKey and (not ShiftKey) and (not AltKey) then begin SetState(false); ElementWindow.ElWind.MIDeleteComponentClick(Sender); exit; end; if KeyCode=vk_Up then if CtrlKey and (not AltKey) and (not ShiftKey) then begin ElementWindow.ElWind.MIParentElementClick(Sender); exit; end; if KeyCode=vk_Left then if (not CtrlKey) and AltKey and (not ShiftKey) then begin PostMessage(ElementWindow.ElWind.Handle,cm_Back,0,0); exit; end; if KeyCode=vk_Right then if (not CtrlKey) and AltKey and (not ShiftKey) then begin PostMessage(ElementWindow.ElWind.Handle,cm_Forward,0,0); exit; end; if KeyCode in [vk_Control, vk_Left,vk_Up,vk_Down,vk_Right,vk_Escape] then {do not set modified to True on navigation keys} exit; if KeyCode=vk_F3 then begin if (not CtrlKey) and (not ShiftKey) and (not AltKey) then begin ElementWindow.ElWind.LockReadPointOnSearch:=true; ElementWindow.ElWind.MISearchTextClick(Sender); exit; end; if (CtrlKey) and (ShiftKey) and (not AltKey) then begin ElementWindow.ElWind.MIShowCitationClick(Sender); exit; end; end; if KeyCode=vk_F6 then begin if (not CtrlKey) and (not ShiftKey) and (not AltKey) then begin PostMessage(ElementWindow.ElWind.Handle,cm_FilterSource,0,0); exit; end; if (CtrlKey) and (ShiftKey) and (not AltKey) then begin ElementWindow.ElWind.MIViewSourceClick(Sender); exit; end; end; if KeyCode=ord('A') then {SMSpecific} if not TrimShortcuts then if CtrlKey and (not ShiftKey) and AltKey then begin Sm8Main.ActAddTaskExecute(Sender); exit; end; if KeyCode=ord('C') then {SMSpecific}{Ctrl+Shift+C does not work} if CtrlKey and ShiftKey and (not AltKey) then begin SM8Main.MICopyClick(Sender); exit; end; if KeyCode=ord('D') then begin {SMSpecific}{Ctrl+Shift+C does not work} if CtrlKey and (not ShiftKey) and (not AltKey) then begin ElementWindow.ElWind.DismissCurrentElement; exit; end; if CtrlKey and (not ShiftKey) and AltKey then begin ElementWindow.ElWind.MIDuplicateClick(Sender); exit; end; end; if KeyCode=ord('F') then if CtrlKey and (not ShiftKey) and (not AltKey) then begin ElementWindow.ElWind.LockReadPointOnSearch:=true; exit; end; if KeyCode=ord('G') then if CtrlKey and (not ShiftKey) and (not AltKey) then begin SM8Main.MIGoToClick(Sender); exit; end; if KeyCode=ord('L') then {SMSpecific}{Ctrl+L does not work} if CtrlKey and (not ShiftKey) and (not AltKey) then begin ElementWindow.ElWind.Learning(lsOutstanding); exit; end; if KeyCode=ord('M') then if CtrlKey and ShiftKey and (not AltKey) then begin ElementWindow.ElWind.ApplyTemplate(false{=do not replace}); exit; end; if KeyCode=ord('N') then if not TrimShortcuts then begin if CtrlKey and (not ShiftKey) and (AltKey) then begin SM8Main.MIAddArticleClick(Sender); exit; end; if (not CtrlKey) and (not ShiftKey) and (AltKey) then begin ElementWindow.ElWind.NextRepetitionClick(Sender); exit; end; end; if KeyCode=ord('P') then begin if CtrlKey and ShiftKey and (not AltKey) then begin ElementWindow.ElWind.MIEditParamtersClick(Sender); exit; end; end; if KeyCode=ord('R') then {SMSpecific}{Ctrl+L does not work} if CtrlKey and ShiftKey and (not AltKey) then begin PostMessage(ElementWindow.ElWind.Handle,cm_ForceRepetition,0,ElementWindow.ElWind.TheElement); exit; end; if KeyCode=ord('Y') then {SMSpecific}{Ctrl+L does not work} if CtrlKey and (not ShiftKey) and (not AltKey) then begin SM8Main.MIMercyClick(Sender); exit; end; if KeyCode=221 {Ctrl+]} then ElementWindow.ElWind.ChangeFontSize(+1); if KeyCode=219 {Ctrl+[} then ElementWindow.ElWind.ChangeFontSize(-1); end; Modified:=true; end; function TWeb.GetTextRange:IHtmlTxtRange; begin Result:=nil; try if TheDoc=nil then exit; while TheDoc.body=nil do begin WaitLoad(true); if TheDoc.body=nil then if QueryC('Wait for document loading?')<>id_Yes then exit; end; if (TheDoc.Selection.type_='Text')or(TheDoc.Selection.type_='None') then Result:=TheDoc.Selection.CreateRange as IHtmlTxtRange; except on E:Exception do EError('This type of selection cannot be processed',E); end; end; initialization FillChar(BrowserData,SizeOf(BrowserData),#0); OleInitialize(nil); New(PtrWGUID); New(PtrMGUID); New(PtrDGUID); PtrWGUID^:=CGID_WebBrowser; PtrMGUID^:=CGID_MSHTML; PtrDGuid:=PGUID(nil); GetBrowserData(BrowserData); IEStr:=IEVerStr; OnMessageCompNo:=0; finalization Dispose(PtrWGUID); Dispose(PtrMGUID); Dispose(PtrDGUID); OleUninitialize; end.
1.4.35-dev.2