I am working on a Sql editor, using TSynEdit in Delphi.
I have my Object names (tables, stored procedures, domains and so on) in the Tablenames of the highlighter and Autocompletion, they show up in blue and underlined which is what i wanted but i wonder if i can make these linked to a event where i can actually open that object.
Is there a way to
a) Change the cursor to handPoint when mouse is over such keyword?
b) Execute a event, procedure, function when clicking on such keyword?
Thanks for any advice.
For getting mouse pointed token information you can write e.g. helper methods like this:
type
TSynEditHelper = class helper for TSynEdit
public
function GetTokenInfo(const CursorPos: TPoint; out TokenType: Integer; out TokenText: UnicodeString): Boolean; overload;
function GetTokenInfo(const LineCharPos: TBufferCoord; out TokenType: Integer; out TokenText: UnicodeString): Boolean; overload;
end;
{ TSynEditHelper }
function TSynEditHelper.GetTokenInfo(const CursorPos: TPoint; out TokenType: Integer; out TokenText: UnicodeString): Boolean;
begin
Result := GetTokenInfo(DisplayToBufferPos(PixelsToRowColumn(CursorPos.X, CursorPos.Y)), TokenType, TokenText);
end;
function TSynEditHelper.GetTokenInfo(const LineCharPos: TBufferCoord; out TokenType: Integer; out TokenText: UnicodeString): Boolean;
var
I: Integer;
A: TSynHighlighterAttributes;
begin
Result := GetHighlighterAttriAtRowColEx(LineCharPos, TokenText, TokenType, I, A);
end;
And use them in the OnMouseCursor for setting the cursor and OnClick for keyword navigation:
procedure TForm1.SynEdit1Click(Sender: TObject);
var
TokenType: Integer;
TokenText: UnicodeString;
begin
if TSynEdit(Sender).GetTokenInfo(TSynEdit(Sender).ScreenToClient(Mouse.CursorPos), TokenType, TokenText) and
(TokenType = Ord(tkTableName)) then
begin
ShowMessage(Format('Table token clicked: %s', [TokenText]));
end;
end;
procedure TForm1.SynEdit1MouseCursor(Sender: TObject; const ALineCharPos: TBufferCoord; var ACursor: TCursor);
var
TokenType: Integer;
TokenText: UnicodeString;
begin
if TSynEdit(Sender).GetTokenInfo(ALineCharPos, TokenType, TokenText) and (TokenType = Ord(tkTableName)) then
ACursor := crHandPoint;
end;
I couldn't find a native way for this feature.
Related
I was looking to read a text file in reverse so it would read in from the bottom of the text file first. I did find how to reverse it but it doesn't make sense to me. Can someone explain this to me, how it's working? Also if there is a better/quicker way? It seems to do all the work after the file is read in, like it would be quicker to just read it in from the bottom.
var
datalist : TStringList;
lines,i : Integer;
saveLine : String;
begin
datalist := TStringList.Create;
datalist.LoadFromFile(filename); //loads file
lines := datalist.Count;
for i := lines-1 downto (lines div 2) do
begin
saveLine := datalist[lines-i-1];
datalist[lines-i-1] := datalist[i];
datalist[i] := saveLine;
end;
(At least in Delphi 7, but more recent versions should act similarily)
.LoadFromFile() calls
.LoadFromStream(), which reads the whole stream/file into memory and then calls
.SetTextStr(), which just calls per line
.Add()
Knowing this helps us to avoiding to reinvent the whole wheel and instead using an own class with one subtle change in the .Add() method:
type
TStringListReverse= class( TStringList )
function Add( const S: String ): Integer; override;
end;
function TStringListReverse.Add( const S: String ): Integer;
begin
Result:= {GetCount} 0; // Our change: always in front
Insert( Result, S );
end;
And now we just use our own class:
var
l: TStringListReverse;
begin
l:= TStringListReverse.Create;
l.LoadFromFile( 'C:\Windows\win.ini' );
Memo1.Lines.Assign( l );
l.Free;
As I mentioned in a comment, it might be useful to create an adapter class that accepts a TStrings instance, and exposes it as another TStrings, but reversed.
This might look like this:
type
TReversedStrings = class(TStrings)
private
FSource: TStrings;
FOwnsSource: Boolean;
function ReversedIndex(Index: Integer): Integer;
protected
procedure Put(Index: Integer; const S: string); override;
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure PutObject(Index: Integer; AObject: TObject); override;
public
constructor Create(Source: TStrings; AssumeOwnership: Boolean);
destructor Destroy; override;
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Exchange(Index1, Index2: Integer); override;
function IndexOf(const S: string): Integer; override;
procedure Insert(Index: Integer; const S: string); override;
procedure Move(CurIndex, NewIndex: Integer); override;
end;
{ TReversedStrings }
constructor TReversedStrings.Create(Source: TStrings; AssumeOwnership: Boolean);
begin
inherited Create;
FSource := Source;
FOwnsSource := AssumeOwnership;
end;
destructor TReversedStrings.Destroy;
begin
if FOwnsSource then
FSource.Free;
inherited;
end;
function TReversedStrings.ReversedIndex(Index: Integer): Integer;
begin
Result := FSource.Count - Index - 1;
end;
procedure TReversedStrings.Put(Index: Integer; const S: string);
begin
FSource[ReversedIndex(Index)] := S;
end;
function TReversedStrings.Get(Index: Integer): string;
begin
Result := FSource[ReversedIndex(Index)];
end;
function TReversedStrings.GetCount: Integer;
begin
Result := FSource.Count;
end;
function TReversedStrings.GetObject(Index: Integer): TObject;
begin
Result := FSource.Objects[ReversedIndex(Index)];
end;
procedure TReversedStrings.PutObject(Index: Integer; AObject: TObject);
begin
FSource.Objects[ReversedIndex(Index)] := AObject;
end;
procedure TReversedStrings.Clear;
begin
FSource.Clear;
end;
procedure TReversedStrings.Delete(Index: Integer);
begin
FSource.Delete(ReversedIndex(Index));
end;
procedure TReversedStrings.Exchange(Index1, Index2: Integer);
begin
FSource.Exchange(ReversedIndex(Index1), ReversedIndex(Index2));
end;
function TReversedStrings.IndexOf(const S: string): Integer;
begin
Result := FSource.IndexOf(S);
if Result > -1 then
Result := ReversedIndex(Result);
end;
procedure TReversedStrings.Insert(Index: Integer; const S: string);
begin
FSource.Insert(ReversedIndex(Index), S);
end;
procedure TReversedStrings.Move(CurIndex, NewIndex: Integer);
begin
FSource.Move(ReversedIndex(CurIndex), ReversedIndex(NewIndex));
end;
It should be obvious how to use this, and I've not tested the code, or even executed it. Consider it a sketch of an idea.
If you want to use the TStringList.LoadFromFile() function, then another way to do it is to copy one TStringList to another TStringList. It would be faster than the current scheme, and is fewer lines of code.
var
datalist1, datalist2 : TStringList;
lines, i: Integer;
filename : string;
begin
datalist1 := TStringList.Create;
datalist2 := TStringList.Create;
datalist1.LoadFromFile(filename); //loads file
lines := datalist1.Count;
data2list.Capacity := lines; // so it allocates the memory once
for i := lines-1 downto 0 do
begin
datalist2.Add (datalist1[i]);
end;
end;
Personally, I would read the file in myself.
I have a working debugger visualizer that helps visualize variables of type TIntTime.
TIntTime = type integer;
The visualizer replaces a number of seconds since midnight with a time string HH:MM:SS. This works fine on variables of type TIntTime during a debug session, but not on functions. For example if I place GetiTime in a watch
function GetiTime: TIntTime;
begin
Result:=30000;
end;
the watch will show 30000. The expected replaced value is '08:20:00'. The visualizer does not intercept function return values of type TIntTime and this is the problem.
I am using Delphi 10 Seattle. My visualizer is based on DateTimeVisualizer.pas found in Delphi 10\source\Visualizers. The DateTimeVisualizer suggests that function return values are intercepted by using the type name string 'function: TIntTime' in GetSupportedType. I have tried
'function: TIntTime'
'function:TIntTime'
'function::TIntTime'
without luck. I suspect it is a question of getting this type name string correct, but haven't been able to find information about the formatting on the internet.
If I instead place GetDateTime in a watch it shows '14-02-2018 13:20:30' as expected. If I switch the TDateTime/TDate/TTime visualizer off in options the watch shows 43145.5559... This tells me that it is possible to intercept function return values with a visualizer.
function GetDateTime: TDateTime;
begin
Result:=EncodeDateTime(2018,2,14,13,20,30,0);
end;
In my case it is not an option to use the TDateTime data type. So my question is: how can I get my visualizer to intercept function return values of type TIntTime?
Below is the source for the TIntTime visualizer
unit IntTimeVisualizer;
interface
procedure Register;
implementation
uses
Classes, Forms, SysUtils, ToolsAPI;
resourcestring
sIntTimeVisualizerName = 'TIntTime Visualizer for Delphi';
sIntTimeVisualizerDescription = 'Displays TIntTime instances in a human-readable time format rather than as an integer value';
type
TDebuggerIntTimeVisualizer = class(TInterfacedObject, IOTADebuggerVisualizer,
IOTADebuggerVisualizerValueReplacer, IOTAThreadNotifier, IOTAThreadNotifier160)
private
FCompleted: Boolean;
FDeferredResult: string;
public
{ IOTADebuggerVisualizer }
function GetSupportedTypeCount: Integer;
procedure GetSupportedType(Index: Integer; var TypeName: string;
var AllDescendants: Boolean);
function GetVisualizerIdentifier: string;
function GetVisualizerName: string;
function GetVisualizerDescription: string;
{ IOTADebuggerVisualizerValueReplacer }
function GetReplacementValue(const Expression, TypeName, EvalResult: string): string;
{ IOTAThreadNotifier }
procedure EvaluteComplete(const ExprStr: string; const ResultStr: string;
CanModify: Boolean; ResultAddress: Cardinal; ResultSize: Cardinal;
ReturnCode: Integer);
procedure ModifyComplete(const ExprStr: string; const ResultStr: string;
ReturnCode: Integer);
procedure ThreadNotify(Reason: TOTANotifyReason);
procedure AfterSave;
procedure BeforeSave;
procedure Destroyed;
procedure Modified;
{ IOTAThreadNotifier160 }
procedure EvaluateComplete(const ExprStr: string; const ResultStr: string;
CanModify: Boolean; ResultAddress: TOTAAddress; ResultSize: LongWord;
ReturnCode: Integer);
end;
TIntTimeType = (dttIntTime);
TIntTimeVisualizerType = record
TypeName: string;
TimeType: TIntTimeType;
end;
const
IntTimeVisualizerTypes: array[0..1] of TIntTimeVisualizerType =
(
(TypeName: 'TIntTime'; TimeType: dttIntTime;), //<-- This type is working fine
(TypeName: 'function: TIntTime'; TimeType: dttIntTime;) //<-- This type is not working
);
{ TDebuggerIntTimeVisualizer }
procedure TDebuggerIntTimeVisualizer.AfterSave;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.BeforeSave;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.Destroyed;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.Modified;
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.ModifyComplete(const ExprStr,
ResultStr: string; ReturnCode: Integer);
begin
// don't care about this notification
end;
procedure TDebuggerIntTimeVisualizer.EvaluteComplete(const ExprStr,
ResultStr: string; CanModify: Boolean; ResultAddress, ResultSize: Cardinal;
ReturnCode: Integer);
begin
EvaluateComplete(ExprStr, ResultStr, CanModify, TOTAAddress(ResultAddress),
LongWord(ResultSize), ReturnCode);
end;
procedure TDebuggerIntTimeVisualizer.EvaluateComplete(const ExprStr,
ResultStr: string; CanModify: Boolean; ResultAddress: TOTAAddress; ResultSize: LongWord;
ReturnCode: Integer);
begin
FCompleted := True;
if ReturnCode = 0 then
FDeferredResult := ResultStr;
end;
procedure TDebuggerIntTimeVisualizer.ThreadNotify(Reason: TOTANotifyReason);
begin
// don't care about this notification
end;
function TDebuggerIntTimeVisualizer.GetReplacementValue(
const Expression, TypeName, EvalResult: string): string;
var
TimeType: TIntTimeType;
I: Integer;
function IntTimeToStr(s: Integer): string;
var
hh, mm, ss: integer;
begin
hh:=s div 3600;
mm:=(s div 60)-hh*60;
ss:=s mod 60;
Result:=Format('%.2d:%.2d:%.2d',[hh,mm,ss]);
end;
function FormatResult(const LEvalResult: string; DTType: TIntTimeType; out ResStr: string): Boolean;
var
IntValue: integer;
begin
Result := True;
try
if not TryStrToInt(LEvalResult, IntValue) then
Result:=false
else
case DTType of
dttIntTime: ResStr:=IntTimeToStr(IntValue);
end;
except
Result := False;
end;
end;
begin
TimeType := TIntTimeType(-1);
for I := Low(IntTimeVisualizerTypes) to High(IntTimeVisualizerTypes) do begin
if TypeName = IntTimeVisualizerTypes[I].TypeName then begin
TimeType:=IntTimeVisualizerTypes[I].TimeType;
Break;
end;
end;
if not FormatResult(EvalResult, TimeType, Result) then
Result := EvalResult;
end;
function TDebuggerIntTimeVisualizer.GetSupportedTypeCount: Integer;
begin
Result := Length(IntTimeVisualizerTypes);
end;
procedure TDebuggerIntTimeVisualizer.GetSupportedType(Index: Integer; var TypeName: string;
var AllDescendants: Boolean);
begin
AllDescendants := false;
TypeName := IntTimeVisualizerTypes[Index].TypeName;
end;
function TDebuggerIntTimeVisualizer.GetVisualizerDescription: string;
begin
Result := sIntTimeVisualizerDescription;
end;
function TDebuggerIntTimeVisualizer.GetVisualizerIdentifier: string;
begin
Result := ClassName;
end;
function TDebuggerIntTimeVisualizer.GetVisualizerName: string;
begin
Result := sIntTimeVisualizerName;
end;
var
IntTimeVis: IOTADebuggerVisualizer;
procedure Register;
begin
IntTimeVis:=TDebuggerIntTimeVisualizer.Create;
(BorlandIDEServices as IOTADebuggerServices).RegisterDebugVisualizer(IntTimeVis);
end;
procedure RemoveVisualizer;
var
DebuggerServices: IOTADebuggerServices;
begin
if Supports(BorlandIDEServices, IOTADebuggerServices, DebuggerServices) then begin
DebuggerServices.UnregisterDebugVisualizer(IntTimeVis);
IntTimeVis:=nil;
end;
end;
initialization
finalization
RemoveVisualizer;
end.
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;
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
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.