How can I avoid refresh with TWebBrowser - delphi

I have a TWebBrowser component that show a Google maps page. The problem is that when user press F5 the page refresh and page reloads. This cause javascript variables to reinitialize and get out of sync with Delphi and a scripting error dialog appear,
'undefined' is null or not an object.
I want to stop refresh from the user.
I tried this event for OnBeforeNavigate2:
procedure TNewOrganizationForm.mapAddressBeforeNavigate2(ASender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
begin
inherited;
Cancel := Assigned(fMapEngine) and not fMapEngine.Loading;
end;
But when I set a breakpoint it is not even called. Is there another way ?

Ronald you can use the IHTMLDocument2.onkeydown event to intercept and block a key.
to assign an event handler first you must create a procedure type using the IHTMLEventObj as parameter.
THTMLProcEvent = procedure(Sender: TObject; Event: IHTMLEventObj) of object;
then you must create an class descendent from InterfacedObject and IDispatch to pass and process the events .
finally you can process the intercepted key in the onkeydown event in this way
Var
HTMLDocument2 : IHTMLDocument2;
begin
if Not Assigned(WebBrowser1.Document) then Exit;
HTMLDocument2:=(WebBrowser1.Document AS IHTMLDocument2);
if HTMLDocument2.parentWindow.event.keyCode=VK_F5 then //compare the key
begin
HTMLDocument2.parentWindow.event.cancelBubble:=True; //cancel the key
HTMLDocument2.parentWindow.event.keyCode :=0;
end;
end;
//check the full source code
unit Unit55;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, SHDocVw, MSHTML;
type
//Create the procedure type to assign the event
THTMLProcEvent = procedure(Sender: TObject; Event: IHTMLEventObj) of object;
//Create a new class for manage the event from the twebbrowser
THTMLEventLink = class(TInterfacedObject, IDispatch)
private
FOnEvent: THTMLProcEvent;
private
constructor Create(Handler: THTMLProcEvent);
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
public
property OnEvent: THTMLProcEvent read FOnEvent write FOnEvent;
end;
TForm55 = class(TForm)
WebBrowser1: TWebBrowser;
procedure FormShow(Sender: TObject);
procedure WebBrowser1NavigateComplete2(ASender: TObject; const pDisp: IDispatch; var URL: OleVariant);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
FOnKeyDownConnector: THTMLEventLink; //pointer to the event handler
procedure WebBrowser1OnKeyDown(Sender: TObject; EventObjIfc: IHTMLEventObj);//the event handler
public
{ Public declarations }
end;
var
Form55: TForm55;
implementation
{$R *.dfm}
constructor THTMLEventLink.Create(Handler: THTMLProcEvent);
begin
inherited Create;
_AddRef;
FOnEvent := Handler;
end;
function THTMLEventLink.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function THTMLEventLink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
end;
function THTMLEventLink.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
end;
function THTMLEventLink.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var
HTMLEventObjIfc: IHTMLEventObj;
begin
Result := S_OK;
if Assigned(FOnEvent) then FOnEvent(Self, HTMLEventObjIfc);
end;
procedure TForm55.FormCreate(Sender: TObject);
begin
FOnKeyDownConnector := THTMLEventLink.Create(WebBrowser1OnKeyDown); //assign the address of the event handler
end;
procedure TForm55.WebBrowser1NavigateComplete2(ASender: TObject; const pDisp: IDispatch; var URL: OleVariant);
var
HTMLDocument2 : IHTMLDocument2;
begin
HTMLDocument2:=(WebBrowser1.Document AS IHTMLDocument2);
HTMLDocument2.onkeydown := FOnKeyDownConnector as IDispatch; //assign the event handler
end;
procedure TForm55.WebBrowser1OnKeyDown(Sender: TObject; EventObjIfc: IHTMLEventObj);
Var
HTMLDocument2 : IHTMLDocument2;
begin
//finally do your stuff here, in this case we will intercept and block the F5 key.
if Not Assigned(WebBrowser1.Document) then Exit;
HTMLDocument2:=(WebBrowser1.Document AS IHTMLDocument2);
if HTMLDocument2.parentWindow.event.keyCode=VK_F5 then
begin
HTMLDocument2.parentWindow.event.cancelBubble:=True;
HTMLDocument2.parentWindow.event.keyCode :=0;
end;
end;
procedure TForm55.FormShow(Sender: TObject);
begin
WebBrowser1.Navigate('www.google.com');
end;
end.

I did not find an easy way to do this. I could not find any event or anything similar on TWebBrowser, that would dissable refresh. Maybe you should check TEmbededWB as it has more events and is more capable than the default TWebBrowser. Otherwise they are very similar.
But I found a way to prevent refresh. Now it is funny that even with KeyPreview set to "True" on the main form I could not recieve key notifications. It seems that TWebBrowser eats them up somehow. But this worked:
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := OnAppMessage;
end;
procedure TForm1.OnAppMessage(var Msg: TMsg; var Handled: Boolean);
begin
if Msg.message = WM_KEYDOWN then
if Msg.wParam = VK_F5 then
Handled := True;
end;
Not the most elegant way but at least it works. I have not found a better solution yet.

Related

Memory leak using IHTMLEventObj handlers with TWebBrowser

I'm using a TWebBrowser to display a WYSIWYG HTML editor and I've added some handlers to catch keyboard and mouse events so I can integrate this editor into my application flow. This browser is integrated in a custom TPanel, TPanelEditorHTML.
This is the way I'm doing it, following some tips from this answer:
//Create the procedure type to assign the event
THTMLProcEvent = procedure(Sender: TObject; Event: IHTMLEventObj) of object;
//Create a new class for manage the event from the twebbrowser
THTMLBrowserEventLink = class(TInterfacedObject, IDispatch)
private
FOnEvent: THTMLProcEvent;
private
constructor Create(Handler: THTMLProcEvent);
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
public
property OnEvent: THTMLProcEvent read FOnEvent write FOnEvent;
end;
On my container for the TWebBrowser I have this:
FOnKeyDownConnector: IDispatch;
FOnClickConnector: IDispatch;
FOnKeyDownConnectorIFrame: IDispatch;
FOnClickConnectorIFrame: IDispatch;
procedure BrowserIHTMLDocument2OnKeyDown(Sender: TObject; Event: IHTMLEventObj);
procedure BrowserIHTMLDocument2OnClick(Sender: TObject; Event: IHTMLEventObj);
procedure IframeIHTMLDocument2OnKeyDown(Sender: TObject; Event: IHTMLEventObj);
procedure IframeIHTMLDocument2OnClick(Sender: TObject; Event: IHTMLEventObj);
Where BrowserIHTMLDocument2OnKeyDown, etc are the procedures where I do all the work integrating the HTML editor data into my application
I create the handlers on startup
constructor TPanelEditorHTML.Create(AOwner: TComponent);
begin
inherited;
// ...
FNavegador := TGENBrowser.Create(self);
FOnKeyDownConnector := THTMLBrowserEventLink.Create(BrowserIHTMLDocument2OnKeyDown);
FOnClickConnector := THTMLBrowserEventLink.Create(BrowserIHTMLDocument2OnClick);
FOnKeyDownConnectorIFrame := THTMLBrowserEventLink.Create(IFrameIHTMLDocument2OnKeyDown);
FOnClickConnectorIFrame := THTMLBrowserEventLink.Create(IFrameIHTMLDocument2OnClick);
end;
And when I load the HTML editor I assign this handlers to a couple of elements in the DOM tree:
procedure TPanelEditorHTML.AsignarManejadores;
var
HTMLDocument2_A, HTMLDocument2_B: IHTMLDocument2;
begin
HTMLDocument2_A := ExtraerIframeEditor;
HTMLDocument2_B := (FNavegador.Document AS IHTMLDocument2);
if (HTMLDocument2_A = nil) or (HTMLDocument2_B = nil) then
Exit;
if (FOnKeyDownConnectorIFrame <> nil) then
HTMLDocument2_A.onkeydown := FOnKeyDownConnectorIFrame;
if (FOnClickConnectorIFrame <> nil) then
HTMLDocument2_A.onclick := FOnClickConnectorIFrame;
if (FOnKeyDownConnector <> nil) then
HTMLDocument2_B.onkeydown := FOnKeyDownConnector;
if (FOnClickConnector <> nil) then
HTMLDocument2_B.onclick := FOnClickConnector;
end;
When the user ends the editing I remove this handlers
procedure TPanelEditorHTML.DesconectarManejadores;
var
HTMLDocument2 : IHTMLDocument2;
begin
HTMLDocument2 := ExtraerIframeEditor;
if (HTMLDocument2 <> nil) then
begin
HTMLDocument2.onkeydown := Unassigned; //assign the event handler
HTMLDocument2.onclick := Unassigned; //assign the event handler
end;
HTMLDocument2:=(FNavegador.Document AS IHTMLDocument2);
if (HTMLDocument2 <> nil) then
begin
HTMLDocument2.onkeydown := Unassigned; //assign the event handler
HTMLDocument2.onclick := Unassigned; //assign the event handler
end;
end;
My problem is on the TPanelEditorHTML destructor. This leads to a memory leak of the four THTMLBrowserEventLink. If I try to FreeAndNil the handlers I get a runtime error.
destructor TPanelEditorHTML.Destroy;
begin
FDataLink.Free;
FOnKeyDownConnector := Unassigned;
FOnClickConnector := Unassigned;
FOnKeyDownConnectorIFrame := Unassigned;
FOnClickConnectorIFrame := Unassigned;
inherited;
end;
I found this article about memory leaks and I tried to replace both methods that were making copies to no avail.
Am I missing something?
As #DalijaPrasnikar said there is a superfluous _AddRef in THTMLEventLink.Create, wich I copied from the solution proposed in this answer.
Changing the constructor of THTMLBrowserEventLink to this:
constructor THTMLBrowserEventLink.Create(Handler: THTMLProcEvent);
begin
inherited Create;
FOnEvent := Handler;
end;
Avoids the memory leak.

Receiving MS Word's automation events from a Delphi app

I've been trying to use the technique shown in the answer to this q
Detect when the active element in a TWebBrowser document changes
to implement a DIY version of MS Word's Automation events.
A fuller extract from my app is below, from which you'll be able to see the
declaration of the variables in these methods:
procedure TForm1.StartWord;
var
IU : IUnknown;
begin
IU := CreateComObject(Class_WordApplication);
App := IU as WordApplication;
App.Visible := True;
IEvt := TEventObject.Create(DocumentOpen);
end;
procedure TForm1.OpenDocument;
var
CPC : IConnectionPointContainer;
CP : IConnectionPoint;
Res : Integer;
MSWord : OleVariant;
begin
Cookie := -1;
CPC := App as IConnectionPointContainer;
Res := CPC.FindConnectionPoint(DIID_ApplicationEvents2, CP);
Res := CP.Advise(IEvt, Cookie);
MSWord := App;
WordDoc:= MSWord.Documents.Open('C:\Docs\Test.Docx');
end;
The StartWord routine works fine. The problem is in OpenDocument. The
value of Res returned by Res := CP.Advise(IEvt, Cookie); is $80040200
This isn't present amongst the HResult status codes in Windows.Pas and googling "ole error 80040200"
returns a few hits involving setting up Ado events from Delphi, but nothing
apparently relevant.
Anyway, the upshot of this is that the Invoke method of the EventObject is never
called, so I don't receive notifications of the WordApplication's events.
So, my question is what does this error $80040200 signify and/or how do I avoid it?
Fwiw, I've also tried connecting to the ApplicationEvents2 interface using this code
procedure TForm1.OpenDocument2;
var
MSWord : OleVariant;
II : IInterface;
begin
II := APP as IInterface;
InterfaceConnect(II, IEvt.EventIID, IEvt as IUnknown, Cookie);
MSWord := App;
WordDoc:= MSWord.Documents.Open('C:\Docs\Test.Docx');
end;
That executes without complaint, but again the EventObject's Invoke method is never
called.
If I drop a TWordApplication onto the blank form of a new application, the events
like OnDocumentOpen work fine. I'm mentioning that because it seems to confirm
that Delphi and MS Word (2007) are correctly set up on my machine.
Code:
uses
... Word2000 ...
TForm1 = class(TForm)
btnStart: TButton;
btnOpenDoc: TButton;
procedure FormCreate(Sender: TObject);
procedure btnOpenDocClick(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure WordApplication1DocumentOpen(ASender: TObject; const Doc: _Document);
private
procedure DocumentOpen(Sender : TObject; DispID : Integer; var Params);
procedure StartWord; // see above for implementation
procedure OpenDocument; // --"--
procedure OpenDocument2; // --"--
public
WordDoc: OleVariant;
IEvt : TEventObject; // see linked question
Cookie : Integer;
App : WordApplication;
[...]
procedure TForm1.WordApplication1DocumentOpen(ASender: TObject; const Doc:
_Document);
begin
//
end;
I could post an MCVE instead, but it would mostly be just the code from the earlier answer.
This had me scratching my head for a while, I can tell you. Anyway, eventually the penny dropped
that the answer must lie in the difference between the way TEventObject is implemented
and TServerEventDispatch in OleServer.Pas.
The key is that TServerEventDispatch implements a custom QueryInterface
function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
begin
Result := S_OK;
Exit;
end;
if IsEqualIID(IID, FServer.FServerData^.EventIID) then
begin
GetInterface(IDispatch, Obj);
Result := S_OK;
Exit;
end;
Result := E_NOINTERFACE;
end;
whereas TEventObject does not. Once I'd spotted that, it was straightforward to extend
TEventObject to do likewise, and voila! the error returned by "CP.Advise" went away.
For completeness, I've included the complete source
of the updated TEventObject below. It is the
if IsEquallIID then ...
which makes the difference between
Res := CP.Advise(IEvt, Cookie);
returning the $800040200 error and zero for success. With the "if IsEquallIID then ..."
commented out, the RefCount on IEvt is 48 (!) after "CP.Advise ..." returns, by which time
TEventObject.QueryInterface has been called no less than 21 times.
I hadn't realised
previously (because TEventObject didn't previously have its own version to observe)
that when "CP.Advise ..." is executed, the COM system calls "TEventObject.QueryInterface"
with a succession of different IIDs until it returns S_Ok on one of them. When I have some free time, maybe I'll try to look up what these other IIDs are: as it is, the IID for IDispatch is quite a long way down the list of IIDs that are queried for, which seems strangely sub-optimal seeing as I'd have though that would be the one that IConnectionPoint.Advise would be trying to get.
Code for updated TEventObject is below. It includes a rather rough'n ready customization
of its Invoke() which is specific to handling Word's DocumentOpen event.
type
TInvokeEvent = procedure(Sender : TObject; const Doc : _Document) of object;
TEventObject = class(TInterfacedObject, IUnknown, IDispatch)
private
FOnEvent: TInvokeEvent;
FEventIID: TGuid;
protected
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
public
constructor Create(const AnEvent : TInvokeEvent);
property OnEvent: TInvokeEvent read FOnEvent write FOnEvent;
property EventIID : TGuid read FEventIID;
end;
constructor TEventObject.Create(const AnEvent: TInvokeEvent);
begin
inherited Create;
FEventIID := DIID_ApplicationEvents2;
FOnEvent := AnEvent;
end;
function TEventObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TEventObject.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Pointer(TypeInfo) := nil;
Result := E_NOTIMPL;
end;
function TEventObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 0;
Result := E_NOTIMPL;
end;
function TEventObject.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var
vPDispParams: PDispParams;
tagV : TagVariant;
V : OleVariant;
Doc : _Document;
begin
vPDispParams := PDispParams(#Params);
if (vPDispParams <> Nil) and (vPDispParams^.rgvarg <> Nil) then begin
tagV := vPDispParams^.rgvarg^[0];
V := OleVariant(tagV);
Doc := IDispatch(V) as _Document;
// the DispID for DocumentOpen of Word's ApplicationEvents2 interface is 4
if (DispID = 4) and Assigned(FOnEvent) then
FOnEvent(Self, Doc);
end;
Result := S_OK;
end;
function TEventObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
begin
Result := S_OK;
Exit;
end;
if IsEqualIID(IID, EventIID) then
begin
GetInterface(IDispatch, Obj);
Result := S_OK;
Exit;
end;
Result := E_NOINTERFACE;
end;

Delphi - Drag and Drop .txt Files in TMemo [duplicate]

In Delphi XE can I allow my form to accept file 'drag and drop' but without having to handle bare windows messages?
You don't need to handle messages to implement this. You just need to implement IDropTarget and call RegisterDragDrop/RevokeDragDrop. It's really very very simple. You can actually implement IDropTarget in your form code but I prefer to do it in a helper class that looks like this:
uses
Winapi.Windows,
Winapi.ActiveX,
Winapi.ShellAPI,
System.StrUtils,
Vcl.Forms;
type
IDragDrop = interface
function DropAllowed(const FileNames: array of string): Boolean;
procedure Drop(const FileNames: array of string);
end;
TDropTarget = class(TObject, IInterface, IDropTarget)
private
// IInterface
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
private
// IDropTarget
FHandle: HWND;
FDragDrop: IDragDrop;
FDropAllowed: Boolean;
procedure GetFileNames(const dataObj: IDataObject; var FileNames: TArray<string>);
procedure SetEffect(var dwEffect: Integer);
function DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; stdcall;
function DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
function DragLeave: HResult; stdcall;
function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
public
constructor Create(AHandle: HWND; const ADragDrop: IDragDrop);
destructor Destroy; override;
end;
{ TDropTarget }
constructor TDropTarget.Create(AHandle: HWND; const ADragDrop: IDragDrop);
begin
inherited Create;
FHandle := AHandle;
FDragDrop := ADragDrop;
RegisterDragDrop(FHandle, Self)
end;
destructor TDropTarget.Destroy;
begin
RevokeDragDrop(FHandle);
inherited;
end;
function TDropTarget.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then begin
Result := S_OK;
end else begin
Result := E_NOINTERFACE;
end;
end;
function TDropTarget._AddRef: Integer;
begin
Result := -1;
end;
function TDropTarget._Release: Integer;
begin
Result := -1;
end;
procedure TDropTarget.GetFileNames(const dataObj: IDataObject; var FileNames: TArray<string>);
var
i: Integer;
formatetcIn: TFormatEtc;
medium: TStgMedium;
dropHandle: HDROP;
begin
FileNames := nil;
formatetcIn.cfFormat := CF_HDROP;
formatetcIn.ptd := nil;
formatetcIn.dwAspect := DVASPECT_CONTENT;
formatetcIn.lindex := -1;
formatetcIn.tymed := TYMED_HGLOBAL;
if dataObj.GetData(formatetcIn, medium)=S_OK then begin
(* This cast needed because HDROP is incorrectly declared as Longint in ShellAPI.pas. It should be declared as THandle
which is an unsigned integer. Without this fix the routine fails in top-down memory allocation scenarios. *)
dropHandle := HDROP(medium.hGlobal);
SetLength(FileNames, DragQueryFile(dropHandle, $FFFFFFFF, nil, 0));
for i := 0 to high(FileNames) do begin
SetLength(FileNames[i], DragQueryFile(dropHandle, i, nil, 0));
DragQueryFile(dropHandle, i, #FileNames[i][1], Length(FileNames[i])+1);
end;
end;
end;
procedure TDropTarget.SetEffect(var dwEffect: Integer);
begin
if FDropAllowed then begin
dwEffect := DROPEFFECT_COPY;
end else begin
dwEffect := DROPEFFECT_NONE;
end;
end;
function TDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
FileNames: TArray<string>;
begin
Result := S_OK;
Try
GetFileNames(dataObj, FileNames);
FDropAllowed := (Length(FileNames)>0) and FDragDrop.DropAllowed(FileNames);
SetEffect(dwEffect);
Except
Result := E_UNEXPECTED;
End;
end;
function TDropTarget.DragLeave: HResult;
begin
Result := S_OK;
end;
function TDropTarget.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
Result := S_OK;
Try
SetEffect(dwEffect);
Except
Result := E_UNEXPECTED;
End;
end;
function TDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
FileNames: TArray<string>;
begin
Result := S_OK;
Try
GetFileNames(dataObj, FileNames);
if Length(FileNames)>0 then begin
FDragDrop.Drop(FileNames);
end;
Except
Application.HandleException(Self);
End;
end;
The idea here is to wrap up the complexity of the Windows IDropTarget in TDropTarget. All you need to do is to implement IDragDrop which is much simpler. Anyway, I think this should get you going.
Create the drop target object from your control's CreateWnd. Destroy it in the DestroyWnd method. That point is important because VCL window re-creation means that a control can have its window handle destroyed and re-created during its lifetime.
Note that reference counting on TDropTarget is suppressed. That is because when RegisterDragDrop is called it increments the reference count. This creates a circular reference and this code to suppress reference counting breaks that. This means that you would use this class through a class variable rather than an interface variable, in order to avoid leaking.
The usage would look something like this:
type
TMainForm = class(TForm, IDragDrop)
....
private
FDropTarget: TDropTarget;
// implement IDragDrop
function DropAllowed(const FileNames: array of string): Boolean;
procedure Drop(const FileNames: array of string);
protected
procedure CreateWindowHandle; override;
procedure DestroyWindowHandle; override;
end;
....
procedure TMainForm.CreateWindowHandle;
begin
inherited;
FDropTarget := TDropTarget.Create(WindowHandle, Self);
end;
procedure TMainForm.DestroyWindowHandle;
begin
FreeAndNil(FDropTarget);
inherited;
end;
function TMainForm.DropAllowed(const FileNames: array of string): Boolean;
begin
Result := True;
end;
procedure TMainForm.Drop(const FileNames: array of string);
begin
; // do something with the file names
end;
Here I am using a form as the drop target. But you could use any other windowed control in a similar fashion.
If you don't like pure WinAPI, then you can use components. Drag and Drop Component Suite is free with sources.
No, unless you are about to peruse some custom TForm descendant which have this functionality built-in already.
I used David Heffernan's solution as base for my test application and got 'Invalid pointer operation' on application close.
The solution for that problem was to change the TDropTarget.Create by adding '_Release;'
constructor TDropTarget.Create(AHandle: HWND; const ADragDrop: IDragDrop);
begin
inherited Create;
FHandle := AHandle;
FDragDrop := ADragDrop;
RegisterDragDrop(FHandle, Self);
_Release;
end;
A discussion about this problem you can see on Embarcadero forum.
You have to either write code yourself, or install a 3rd party product like DropMaster, which lets you do drag and drop in much older Delphi versions as well.
--jeroen

How to draw something over WebBrowser component in Delphi

Is it possible to draw or put something over the WebBrowser component to draw on it ?
When I add an image on WebBrowser this image is always under the WebBrowser.
I need this to draw area over different map types always in the same way.
For example I need to draw the same area on Google Maps and open street maps...
You should use IHTMLPainter.Draw event method for doing this. The following code needs a TWebBrowser where you have to write the OnDocumentComplete event handler.
Note that this example has one big weakness, the user input events like mouse clicking are active because the only thing what this example do is the painting over the element. I've been playing with this a little bit, but without success. This might be a good topic for another question.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
StdCtrls, SHDocVw, MSHTML, OleCtrls;
type
TElementBehavior = class(TInterfacedObject, IElementBehavior, IHTMLPainter)
private
FPaintSite: IHTMLPaintSite;
public
{ IElementBehavior }
function Init(const pBehaviorSite: IElementBehaviorSite): HRESULT; stdcall;
function Notify(lEvent: Integer; var pVar: OleVariant): HRESULT; stdcall;
function Detach: HRESULT; stdcall;
{ IHTMLPainter }
function Draw(rcBounds: tagRECT; rcUpdate: tagRECT; lDrawFlags: Integer;
hdc: hdc; pvDrawObject: Pointer): HRESULT; stdcall;
function OnResize(size: tagSIZE): HRESULT; stdcall;
function GetPainterInfo(out pInfo: _HTML_PAINTER_INFO): HRESULT; stdcall;
function HitTestPoint(pt: tagPOINT; out pbHit: Integer; out plPartID: Integer): HRESULT; stdcall;
end;
TElementBehaviorFactory = class(TInterfacedObject, IElementBehaviorFactory)
public
function FindBehavior(const bstrBehavior: WideString;
const bstrBehaviorUrl: WideString; const pSite: IElementBehaviorSite;
out ppBehavior: IElementBehavior): HRESULT; stdcall;
end;
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure WebBrowser1DocumentComplete(ASender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Image: TBitmap;
Behavior: TElementBehavior;
Factory: TElementBehaviorFactory;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Image := TBitmap.Create;
Image.LoadFromFile('c:\yourpicture.bmp');
WebBrowser1.Navigate('maps.google.com');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Behavior := nil;
Factory := nil;
Image.Free;
end;
procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
HTMLElement: IHTMLElement2;
FactoryVariant: OleVariant;
begin
HTMLElement := (WebBrowser1.Document as IHTMLDocument3).getElementById('map') as IHTMLElement2;
if Assigned(HTMLElement) then
begin
Behavior := TElementBehavior.Create;
Factory := TElementBehaviorFactory.Create;
FactoryVariant := IElementBehaviorFactory(Factory);
HTMLElement.addBehavior('', FactoryVariant);
end;
end;
function TElementBehaviorFactory.FindBehavior(const bstrBehavior,
bstrBehaviorUrl: WideString; const pSite: IElementBehaviorSite;
out ppBehavior: IElementBehavior): HRESULT;
begin
ppBehavior := Behavior;
Result := S_OK;
end;
function TElementBehavior.Draw(rcBounds: tagRECT; rcUpdate: tagRECT; lDrawFlags: Integer;
hdc: hdc; pvDrawObject: Pointer): HRESULT;
begin
StretchBlt(
hdc,
rcBounds.Left,
rcBounds.Top,
rcBounds.Right - rcBounds.Left,
rcBounds.Bottom - rcBounds.Top,
Image.Canvas.Handle,
0,
0,
Image.Canvas.ClipRect.Right - Image.Canvas.ClipRect.Left,
Image.Canvas.ClipRect.Bottom - Image.Canvas.ClipRect.Top,
SRCCOPY);
Result := S_OK;
end;
function TElementBehavior.GetPainterInfo(out pInfo: _HTML_PAINTER_INFO): HRESULT;
begin
pInfo.lFlags := HTMLPAINTER_OPAQUE;
pInfo.lZOrder := HTMLPAINT_ZORDER_WINDOW_TOP;
FillChar(pInfo.rcExpand, SizeOf(TRect), 0);
Result := S_OK;
end;
function TElementBehavior.HitTestPoint(pt: tagPOINT; out pbHit,
plPartID: Integer): HRESULT;
begin
Result := E_NOTIMPL;
end;
function TElementBehavior.OnResize(size: tagSIZE): HRESULT;
begin
Result := S_OK;
end;
function TElementBehavior.Detach: HRESULT;
begin
if Assigned(FPaintSite) then
FPaintSite.InvalidateRect(nil);
Result := S_OK;
end;
function TElementBehavior.Init(
const pBehaviorSite: IElementBehaviorSite): HRESULT;
begin
Result := pBehaviorSite.QueryInterface(IHTMLPaintSite, FPaintSite);
if Assigned(FPaintSite) then
FPaintSite.InvalidateRect(nil);
end;
function TElementBehavior.Notify(lEvent: Integer;
var pVar: OleVariant): HRESULT;
begin
Result := E_NOTIMPL;
end;
end.

Is there a Preview Handler VCL for Windows 7?

This article
http://msdn.microsoft.com/en-gb/library/bb776867.aspx
describes preview handlers in Windows as
Preview handlers are called when an
item is selected to show a
lightweight, rich, read-only preview
of the file's contents in the view's
reading pane. This is done without
launching the file's associated
application.
and ...
A preview handler is a hosted
application. Hosts include the
Microsoft Windows Explorer in Windows
Vista or Microsoft Outlook 2007.
Is there some Delphi VCL code which can be used as a startingpoint for such a handler?
#Mjn, right know I'm writing an article for my blog to implement Preview Handlers from Delphi, but due to lack of time, I do not know when this is complete, as others users mention by the moment no exist a VCL component in Delphi to implement preview handlers, in the past I implemented a couple of preview handlers for a customer but using Delphi-Prism and C#.
As starting point here I leave some tips.
You must use the IPreviewHandler, InitializeWithFile, InitializeWithStream, IPreviewHandlerFrame, IPreviewHandlerVisuals interfaces.
This is the Delphi translation of the headers of these interfaces
uses
Windows, ActiveX, AxCtrls, ShlObj, ComObj;
type
IIPreviewHandler = interface(IUnknown)
['{8895b1c6-b41f-4c1c-a562-0d564250836f}']
function SetWindow(hwnd: HWND; var RectangleRef: TRect): HRESULT; stdcall;
function SetRect(var RectangleRef: TRect): HRESULT; stdcall;
function DoPreview(): HRESULT; stdcall;
function Unload(): HRESULT; stdcall;
function SetFocus(): HRESULT; stdcall;
function QueryFocus(phwnd: HWND): HRESULT; stdcall;
function TranslateAccelerator(PointerToWindowMessage: MSG): HRESULT; stdcall;
end;
IInitializeWithFile = interface(IUnknown)
['{b7d14566-0509-4cce-a71f-0a554233bd9b}']
function Initialize(pszFilePath: LPWSTR; grfMode: DWORD):HRESULT;stdcall;
end;
IInitializeWithStream = interface(IUnknown)
['{b824b49d-22ac-4161-ac8a-9916e8fa3f7f}']
function Initialize(pstream: IStream; grfMode: DWORD): HRESULT; stdcall;
end;
IIPreviewHandlerFrame = interface(IUnknown)
['{fec87aaf-35f9-447a-adb7-20234491401a}']
function GetWindowContext(pinfo: HWND): HRESULT; stdcall;
function TranslateAccelerator(PointerToWindowMessage: MSG): HRESULT; stdcall;
end;
IIPreviewHandlerVisuals = interface(IUnknown)
['{8327b13c-b63f-4b24-9b8a-d010dcc3f599}']
function SetBackgroundColor(color: COLORREF ): HRESULT; stdcall;
function SetFont(plf:LOGFONTW): HRESULT; stdcall;
function SetTextColor(color: COLORREF): HRESULT; stdcall;
end;
You must create a com dll with a class which descend from these interfaces IIPreviewHandler, IIPreviewHandlerVisuals, IOleWindow, IObjectWithSite to manage the visualization and a second class to load the files to show. this class must descend from IPreviewHandler, IInitializeWithStream.
something like this
TMyPreviewHandler = class(IIPreviewHandler, IIPreviewHandlerVisuals, IOleWindow, IObjectWithSite)
TMyStream = class(IIPreviewHandler, IInitializeWithStream, IStream)
Now you must create your own implementation of the methods for the parent interfaces.
this is the list of the methods which you need implement.
IPreviewHandler -> DoPreview, SetWindow, SetRect, Unload, SetFocus, TranslateAccelerator, QueryFocus.
IObjectWithSite -> GetSite, SetSite.
IOleWindow -> GetWindow
IPreviewHandlerVisuals - > SetBackgroundColor, SetFont, SetColor
InitializeWithStream -> Initialize
finally you must register your COM in the system as well as the file extensions which will use you PrevieHandler class.
Check this project as a starting point Windows Preview Handler Pack (is written in C#) and this article View Data Your Way With Our Managed Preview Handler Framework
I have made this unit to handle all the preview handler stuff:
unit PreviewHandler;
{$WARN SYMBOL_PLATFORM OFF}
{.$DEFINE USE_CODESITE}
interface
uses
Classes, Controls, ComObj;
type
TPreviewHandler = class abstract
public
{ Create all controls needed for the preview and connect them to the
parent given. The parent follows the size, color and font of the preview
pane. The parent will stay valid until this instance is destroyed, so if
you make the parent also the owner of the controls you don't need to free
them in Destroy. }
constructor Create(AParent: TWinControl); virtual;
class function GetComClass: TComClass; virtual; abstract;
class procedure Register(const AClassID: TGUID; const AName, ADescription, AFileExtension: string);
{$REGION 'Clear Content'}
/// <summary>Clear Content</summary>
/// <remarks>This method is called when the preview should be cleared because
/// either another item was selected or the PreviewHandler will be
/// closed.</remarks>
{$ENDREGION}
procedure Unload; virtual;
end;
TStreamPreviewHandler = class abstract(TPreviewHandler)
public
{$REGION 'Render the preview from the stream data'}
/// <summary>Render the preview from the stream data</summary>
/// <remarks>Here you should render the data from the stream in whatever
/// fashion you want.</remarks>
{$ENDREGION}
procedure DoPreview(Stream: TStream); virtual; abstract;
class function GetComClass: TComClass; override; final;
end;
TFilePreviewHandler = class abstract(TPreviewHandler)
public
{$REGION 'Render the preview from the file path'}
/// <summary>Render the preview from the file path</summary>
/// <remarks>Here you should render the data from the file path in whatever
/// fashion you want.</remarks>
{$ENDREGION}
procedure DoPreview(const FilePath: String); virtual; abstract;
class function GetComClass: TComClass; override; final;
end;
implementation
uses
{$IFDEF USE_CODESITE}
CodeSiteLogging,
{$ENDIF}
Windows, ActiveX, ComServ, ShlObj, PropSys, Types, SysUtils, Graphics, ExtCtrls;
type
TPreviewHandlerClass = class of TPreviewHandler;
TComPreviewHandler = class(TComObject, IPreviewHandler, IPreviewHandlerVisuals, IObjectWithSite, IOleWindow)
strict private
function IPreviewHandler.DoPreview = IPreviewHandler_DoPreview;
function ContextSensitiveHelp(fEnterMode: LongBool): HRESULT; stdcall;
function GetSite(const riid: TGUID; out site: IInterface): HRESULT; stdcall;
function GetWindow(out wnd: HWND): HRESULT; stdcall;
function IPreviewHandler_DoPreview: HRESULT; stdcall;
function QueryFocus(var phwnd: HWND): HRESULT; stdcall;
function SetBackgroundColor(color: Cardinal): HRESULT; stdcall;
function SetFocus: HRESULT; stdcall;
function SetFont(const plf: tagLOGFONTW): HRESULT; stdcall;
function SetRect(var prc: TRect): HRESULT; stdcall;
function SetSite(const pUnkSite: IInterface): HRESULT; stdcall;
function SetTextColor(color: Cardinal): HRESULT; stdcall;
function SetWindow(hwnd: HWND; var prc: TRect): HRESULT; stdcall;
function TranslateAccelerator(var pmsg: tagMSG): HRESULT; stdcall;
function Unload: HRESULT; stdcall;
private
FBackgroundColor: Cardinal;
FBounds: TRect;
FContainer: TWinControl;
FLogFont: tagLOGFONTW;
FParentWindow: HWND;
FPreviewHandler: TPreviewHandler;
FPreviewHandlerClass: TPreviewHandlerClass;
FPreviewHandlerFrame: IPreviewHandlerFrame;
FSite: IInterface;
FTextColor: Cardinal;
protected
procedure CheckContainer;
procedure CheckPreviewHandler;
procedure InternalUnload; virtual; abstract;
procedure InternalDoPreview; virtual; abstract;
property Container: TWinControl read FContainer;
property PreviewHandler: TPreviewHandler read FPreviewHandler;
public
destructor Destroy; override;
property PreviewHandlerClass: TPreviewHandlerClass read FPreviewHandlerClass write FPreviewHandlerClass;
end;
TComStreamPreviewHandler = class(TComPreviewHandler, IInitializeWithStream)
strict private
function IInitializeWithStream.Initialize = IInitializeWithStream_Initialize;
function IInitializeWithStream_Initialize(const pstream: IStream; grfMode: Cardinal): HRESULT; stdcall;
private
FIStream: IStream;
FMode: Cardinal;
function GetPreviewHandler: TStreamPreviewHandler;
protected
procedure InternalUnload; override;
procedure InternalDoPreview; override;
property PreviewHandler: TStreamPreviewHandler read GetPreviewHandler;
end;
TComFilePreviewHandler = class(TComPreviewHandler, IInitializeWithFile)
strict private
function IInitializeWithFile.Initialize = IInitializeWithFile_Initialize;
function IInitializeWithFile_Initialize(pszFilePath: LPCWSTR; grfMode: DWORD): HRESULT; stdcall;
private
FFilePath: string;
FMode: DWORD;
function GetPreviewHandler: TFilePreviewHandler;
protected
procedure InternalDoPreview; override;
procedure InternalUnload; override;
property PreviewHandler: TFilePreviewHandler read GetPreviewHandler;
end;
TComPreviewHandlerFactory = class(TComObjectFactory)
private
FFileExtension: string;
FPreviewHandlerClass: TPreviewHandlerClass;
class procedure DeleteRegValue(const Key, ValueName: string; RootKey: DWord);
class function IsRunningOnWOW64: Boolean;
protected
property FileExtension: string read FFileExtension;
public
constructor Create(APreviewHandlerClass: TPreviewHandlerClass; const AClassID: TGUID; const AName, ADescription, AFileExtension: string);
function CreateComObject(const Controller: IUnknown): TComObject; override;
procedure UpdateRegistry(Register: Boolean); override;
property PreviewHandlerClass: TPreviewHandlerClass read FPreviewHandlerClass;
end;
TWinControlHelper = class helper for TWinControl
public
procedure SetFocusTabFirst;
procedure SetFocusTabLast;
procedure SetBackgroundColor(AColor: Cardinal);
procedure SetBoundsRect(const ARect: TRect);
procedure SetTextColor(AColor: Cardinal);
procedure SetTextFont(const Source: tagLOGFONTW);
end;
TIStreamAdapter = class(TStream)
private
FTarget: IStream;
protected
function GetSize: Int64; override;
procedure SetSize(NewSize: Longint); override;
procedure SetSize(const NewSize: Int64); override;
public
constructor Create(ATarget: IStream);
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; override;
function Write(const Buffer; Count: Longint): Longint; override;
property Target: IStream read FTarget;
end;
procedure TWinControlHelper.SetFocusTabFirst;
begin
SelectNext(nil, true, true);
end;
procedure TWinControlHelper.SetFocusTabLast;
begin
SelectNext(nil, false, true);
end;
procedure TWinControlHelper.SetBackgroundColor(AColor: Cardinal);
begin
Color := AColor;
end;
procedure TWinControlHelper.SetBoundsRect(const ARect: TRect);
begin
SetBounds(ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
end;
procedure TWinControlHelper.SetTextColor(AColor: Cardinal);
begin
Font.Color := AColor;
end;
procedure TWinControlHelper.SetTextFont(const Source: tagLOGFONTW);
var
fontStyle: TFontStyles;
begin
Font.Height := Source.lfHeight;
fontStyle := Font.Style;
if Source.lfWeight >= FW_BOLD then
Include(fontStyle, fsBold);
if Source.lfItalic = 1 then
Include(fontStyle, fsItalic);
if Source.lfUnderline = 1 then
Include(fontStyle, fsUnderline);
if Source.lfStrikeOut = 1 then
Include(fontStyle, fsStrikeOut);
Font.Style := fontStyle;
Font.Charset := TFontCharset(Source.lfCharSet);
Font.Name := Source.lfFaceName;
case Source.lfPitchAndFamily and $F of
VARIABLE_PITCH: Font.Pitch := fpVariable;
FIXED_PITCH: Font.Pitch := fpFixed;
else
Font.Pitch := fpDefault;
end;
Font.Orientation := Source.lfOrientation;
end;
constructor TComPreviewHandlerFactory.Create(APreviewHandlerClass: TPreviewHandlerClass; const AClassID: TGUID; const
AName, ADescription, AFileExtension: string);
begin
inherited Create(ComServ.ComServer, APreviewHandlerClass.GetComClass, AClassID, AName, ADescription, ciMultiInstance, tmApartment);
FPreviewHandlerClass := APreviewHandlerClass;
FFileExtension := AFileExtension;
end;
function TComPreviewHandlerFactory.CreateComObject(const Controller: IUnknown): TComObject;
begin
result := inherited CreateComObject(Controller);
TComPreviewHandler(result).PreviewHandlerClass := PreviewHandlerClass;
end;
class procedure TComPreviewHandlerFactory.DeleteRegValue(const Key, ValueName: string; RootKey: DWord);
var
RegKey: HKEY;
begin
if RegOpenKeyEx(RootKey, PChar(Key), 0, KEY_ALL_ACCESS, regKey) = ERROR_SUCCESS then begin
try
RegDeleteValue(regKey, PChar(ValueName));
finally
RegCloseKey(regKey)
end;
end;
end;
class function TComPreviewHandlerFactory.IsRunningOnWOW64: Boolean;
{ code taken from www.delphidabbler.com "IsWow64" }
type
// Type of IsWow64Process API fn
TIsWow64Process = function(Handle: Windows.THandle; var Res: Windows.BOOL): Windows.BOOL; stdcall;
var
IsWow64Result: Windows.BOOL; // Result from IsWow64Process
IsWow64Process: TIsWow64Process; // IsWow64Process fn reference
begin
{$IF defined(CPUX64)}
// compiled for 64-bit: can't be running on Wow64
result := false;
{$ELSE}
// Try to load required function from kernel32
IsWow64Process := Windows.GetProcAddress(Windows.GetModuleHandle('kernel32'), 'IsWow64Process');
if Assigned(IsWow64Process) then begin
// Function is implemented: call it
if not IsWow64Process(Windows.GetCurrentProcess, IsWow64Result) then
raise SysUtils.Exception.Create('IsWindows64: bad process handle');
// Return result of function
Result := IsWow64Result;
end
else
// Function not implemented: can't be running on Wow64
Result := False;
{$IFEND}
end;
procedure TComPreviewHandlerFactory.UpdateRegistry(Register: Boolean);
var
plainFileName: string;
sAppID, sClassID, ProgID, ServerKeyName, RegPrefix: string;
RootKey: HKEY;
RootKey2: HKEY;
begin
if Instancing = ciInternal then
Exit;
ComServer.GetRegRootAndPrefix(RootKey, RegPrefix);
if ComServer.PerUserRegistration then
RootKey2 := HKEY_CURRENT_USER
else
RootKey2 := HKEY_LOCAL_MACHINE;
sClassID := GUIDToString(ClassID);
ProgID := GetProgID;
ServerKeyName := RegPrefix + 'CLSID\' + sClassID + '\' + ComServer.ServerKey;
if IsRunningOnWOW64 then
sAppID := '{534A1E02-D58F-44f0-B58B-36CBED287C7C}' // for Win32 shell extension running on Win64
else
sAppID := '{6d2b5079-2f0b-48dd-ab7f-97cec514d30b}';
if Register then begin
inherited;
plainFileName := ExtractFileName(ComServer.ServerFileName);
CreateRegKey(RegPrefix + 'CLSID\' + sClassID, 'AppID', sAppID, RootKey);
if ProgID <> '' then begin
CreateRegKey(ServerKeyName, 'ProgID', ProgID, RootKey);
CreateRegKey(ServerKeyName, 'VersionIndependentProgID', ProgID, RootKey);
CreateRegKey(RegPrefix + ProgID + '\shellex\' + SID_IPreviewHandler, '', sClassID, RootKey);
CreateRegKey(RegPrefix + FileExtension, '', ProgID, RootKey);
CreateRegKey('SOFTWARE\Microsoft\Windows\CurrentVersion\PreviewHandlers', sClassID, Description, RootKey2);
end;
end
else begin
if ProgID <> '' then begin
DeleteRegValue('SOFTWARE\Microsoft\Windows\CurrentVersion\PreviewHandlers', sClassID, RootKey2);
DeleteRegKey(RegPrefix + FileExtension, RootKey);
DeleteRegKey(RegPrefix + ProgID + '\shellex', RootKey);
end;
inherited;
end;
end;
destructor TComPreviewHandler.Destroy;
begin
FPreviewHandler.Free;
FContainer.Free;
inherited Destroy;
end;
procedure TComPreviewHandler.CheckContainer;
begin
if FContainer = nil then begin
{ I sprang for a TPanel here, because it makes things so much simpler. }
FContainer := TPanel.Create(nil);
TPanel(FContainer).BevelOuter := bvNone;
FContainer.SetBackgroundColor(FBackgroundColor);
FContainer.SetTextFont(FLogFont);
FContainer.SetTextColor(FTextColor);
FContainer.SetBoundsRect(FBounds);
FContainer.ParentWindow := FParentWindow;
end;
end;
procedure TComPreviewHandler.CheckPreviewHandler;
begin
if FPreviewHandler = nil then begin
CheckContainer;
FPreviewHandler := PreviewHandlerClass.Create(Container);
end;
end;
function TComPreviewHandler.ContextSensitiveHelp(fEnterMode: LongBool): HRESULT;
begin
result := E_NOTIMPL;
end;
function TComPreviewHandler.GetSite(const riid: TGUID; out site: IInterface): HRESULT;
begin
site := nil;
if FSite = nil then
result := E_FAIL
else if Supports(FSite, riid, site) then
result := S_OK
else
result := E_NOINTERFACE;
end;
function TComPreviewHandler.GetWindow(out wnd: HWND): HRESULT;
begin
if Container = nil then begin
result := E_FAIL;
end
else begin
wnd := Container.Handle;
result := S_OK;
end;
end;
function TComPreviewHandler.IPreviewHandler_DoPreview: HRESULT;
begin
try
CheckPreviewHandler;
InternalDoPreview;
except
on E: Exception do begin
{$IFDEF USE_CODESITE}
CodeSite.SendException(E);
{$ENDIF}
end;
end;
result := S_OK;
end;
function TComPreviewHandler.QueryFocus(var phwnd: HWND): HRESULT;
begin
phwnd := GetFocus;
result := S_OK;
end;
function TComPreviewHandler.SetBackgroundColor(color: Cardinal): HRESULT;
begin
FBackgroundColor := color;
if Container <> nil then
Container.SetBackgroundColor(FBackgroundColor);
result := S_OK;
end;
function TComPreviewHandler.SetFocus: HRESULT;
begin
if Container <> nil then begin
if GetKeyState(VK_SHIFT) < 0 then
Container.SetFocusTabLast
else
Container.SetFocusTabFirst;
end;
result := S_OK;
end;
function TComPreviewHandler.SetFont(const plf: tagLOGFONTW): HRESULT;
begin
FLogFont := plf;
if Container <> nil then
Container.SetTextFont(FLogFont);
result := S_OK;
end;
function TComPreviewHandler.SetRect(var prc: TRect): HRESULT;
begin
FBounds := prc;
if Container <> nil then
Container.SetBoundsRect(FBounds);
result := S_OK;
end;
function TComPreviewHandler.SetSite(const pUnkSite: IInterface): HRESULT;
begin
FSite := PUnkSite;
FPreviewHandlerFrame := FSite as IPreviewHandlerFrame;
result := S_OK;
end;
function TComPreviewHandler.SetTextColor(color: Cardinal): HRESULT;
begin
FTextColor := color;
if Container <> nil then
Container.SetTextColor(FTextColor);
result := S_OK;
end;
function TComPreviewHandler.SetWindow(hwnd: HWND; var prc: TRect): HRESULT;
begin
FParentWindow := hwnd;
FBounds := prc;
if Container <> nil then begin
Container.ParentWindow := FParentWindow;
Container.SetBoundsRect(FBounds);
end;
result := S_OK;
end;
function TComPreviewHandler.TranslateAccelerator(var pmsg: tagMSG): HRESULT;
begin
if FPreviewHandlerFrame = nil then
result := S_FALSE
else
result := FPreviewHandlerFrame.TranslateAccelerator(pmsg);
end;
function TComPreviewHandler.Unload: HRESULT;
begin
if PreviewHandler <> nil then
PreviewHandler.Unload;
InternalUnload;
result := S_OK;
end;
constructor TPreviewHandler.Create(AParent: TWinControl);
begin
inherited Create;
end;
class procedure TPreviewHandler.Register(const AClassID: TGUID; const AName, ADescription, AFileExtension: string);
begin
TComPreviewHandlerFactory.Create(Self, AClassID, AName, ADescription, AFileExtension);
end;
procedure TPreviewHandler.Unload;
begin
end;
constructor TIStreamAdapter.Create(ATarget: IStream);
begin
inherited Create;
FTarget := ATarget;
end;
function TIStreamAdapter.GetSize: Int64;
var
statStg: TStatStg;
begin
if Target.Stat(statStg, STATFLAG_NONAME) = S_OK then
result := statStg.cbSize
else
result := -1;
end;
function TIStreamAdapter.Read(var Buffer; Count: Longint): Longint;
begin
Target.Read(#Buffer, Count, #result);
end;
function TIStreamAdapter.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Target.Seek(Offset, Ord(Origin), result);
end;
procedure TIStreamAdapter.SetSize(const NewSize: Int64);
begin
raise ENotImplemented.Create('SetSize not implemented');
// Target.SetSize(NewSize);
end;
procedure TIStreamAdapter.SetSize(NewSize: Longint);
begin
SetSize(Int64(NewSize));
end;
function TIStreamAdapter.Write(const Buffer; Count: Longint): Longint;
begin
raise ENotImplemented.Create('Write not implemented');
// Target.Write(#Buffer, Count, #result);
end;
function TComStreamPreviewHandler.GetPreviewHandler: TStreamPreviewHandler;
begin
Result := inherited PreviewHandler as TStreamPreviewHandler;
end;
function TComStreamPreviewHandler.IInitializeWithStream_Initialize(const pstream: IStream; grfMode: Cardinal): HRESULT;
begin
FIStream := pStream;
FMode := grfMode;
result := S_OK;
end;
procedure TComStreamPreviewHandler.InternalUnload;
begin
FIStream := nil;
end;
procedure TComStreamPreviewHandler.InternalDoPreview;
var
stream: TIStreamAdapter;
begin
stream := TIStreamAdapter.Create(FIStream);
try
PreviewHandler.DoPreview(stream);
finally
stream.Free;
end;
end;
function TComFilePreviewHandler.GetPreviewHandler: TFilePreviewHandler;
begin
Result := inherited PreviewHandler as TFilePreviewHandler;
end;
function TComFilePreviewHandler.IInitializeWithFile_Initialize(pszFilePath: LPCWSTR; grfMode: DWORD): HRESULT;
begin
FFilePath := pszFilePath;
FMode := grfMode;
result := S_OK;
end;
procedure TComFilePreviewHandler.InternalDoPreview;
begin
PreviewHandler.DoPreview(FFilePath);
end;
procedure TComFilePreviewHandler.InternalUnload;
begin
FFilePath := '';
end;
class function TFilePreviewHandler.GetComClass: TComClass;
begin
result := TComFilePreviewHandler;
end;
class function TStreamPreviewHandler.GetComClass: TComClass;
begin
result := TComStreamPreviewHandler;
end;
initialization
{$IFDEF USE_CODESITE}
CodeSiteManager.ConnectUsingTcp;
{$ENDIF}
end.
A sample preview handler based on this unit is shown here:
unit MyPreviewHandler;
interface
uses
PreviewHandler, Classes, Controls, StdCtrls;
const
{$REGION 'Unique ClassID of your PreviewHandler'}
/// <summary>Unique ClassID of your PreviewHandler</summary>
/// <remarks>Don't forget to create a new one. Best use Ctrl-G.</remarks>
{$ENDREGION}
CLASS_MyPreviewHandler: TGUID = '{64644512-C345-469F-B5FB-EB351E20129D}';
type
{$REGION 'Sample PreviewHandler'}
/// <summary>Sample PreviewHandler</summary>
/// <remarks>A sample PreviewHandler. You only have to derive from
/// TFilePreviewHandler or TStreamPreviewHandler and override some methods.</remarks>
{$ENDREGION}
TMyPreviewHandler = class(TFilePreviewHandler)
private
FTextLabel: TLabel;
protected
public
constructor Create(AParent: TWinControl); override;
procedure Unload; override;
procedure DoPreview(const FilePath: string); override;
property TextLabel: TLabel read FTextLabel;
end;
implementation
uses
SysUtils;
constructor TMyPreviewHandler.Create(AParent: TWinControl);
begin
inherited;
FTextLabel := TLabel.Create(AParent);
FTextLabel.Parent := AParent;
FTextLabel.AutoSize := false;
FTextLabel.Align := alClient;
FTextLabel.Alignment := taCenter;
FTextLabel.Layout := tlCenter;
FTextLabel.WordWrap := true;
end;
procedure TMyPreviewHandler.DoPreview(const FilePath: string);
begin
TextLabel.Caption := GetPackageDescription(PWideChar(FilePath));
end;
procedure TMyPreviewHandler.Unload;
begin
TextLabel.Caption := '';
inherited;
end;
initialization
{ Register your PreviewHandler with the ClassID, name, descripton and file extension }
TMyPreviewHandler.Register(CLASS_MyPreviewHandler, 'bplfile', 'BPL Binary Preview Handler', '.bpl');
end.
library MyPreviewHandlerLib;
uses
ComServ,
PreviewHandler in 'PreviewHandler.pas' {PreviewHandler: CoClass},
MyPreviewHandler in 'MyPreviewHandler.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer,
DllInstall;
{$R *.RES}
begin
end.
You may be interested in this article in my blog describing some more details on that framework.
I have never seen such a thing, but since the whole thing is build in COM, you would start by importing the type library, and implementing the required interfaces, including IPreviewHandlerFrame. [Sorry, not very helpful. But this is a pretty obscure area, so I'm not surprised that Delphi hasn't got a prebuilt component set for this.]
I can't find any references to using IPreviewHandlerFrame in Delphi, but did manage to come up with a C# example here - maybe it'll give you a starting point.
I think you have to write a COM-Server yourself, which provides the described IPreviwHandler-Interfacees. (There is no type library to import...) I am very interested in such a code as well and I am searching for quite a while now. I am not very experienced with COM-Server-writing... If you find something, let me know please! As I will share my code also, if I get some...
Andreas

Resources