unit DropURLTarget;
// -----------------------------------------------------------------------------
// Project: Drag and Drop Component Suite
// Component Names: TDropURLTarget
// Module: DropURLTarget
// Description: Implements Dragging & Dropping of URLs
// TO your application from another.
// Version: 3.7
// Date: 22-APR-1999
// Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4
// Authors: Angus Johnson, ajohnson@rpi.net.au
// Anders Melander, anders@melander.dk
// http://www.melander.dk
// Copyright © 1997-99 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
interface
uses
DropSource, DropTarget,
Classes, ActiveX;
{$include DragDrop.inc}
type
TDropURLTarget = class(TDropTarget)
private
URLFormatEtc,
FileContentsFormatEtc,
FGDFormatEtc: TFormatEtc;
fURL: String;
fTitle: String;
protected
procedure ClearData; override;
function DoGetData: boolean; override;
function HasValidFormats: boolean; override;
public
constructor Create(AOwner: TComponent); override;
property URL: String Read fURL Write fURL;
property Title: String Read fTitle Write fTitle;
end;
procedure Register;
implementation
uses
Windows,
SysUtils,
ShlObj;
procedure Register;
begin
RegisterComponents('DragDrop', [TDropURLTarget]);
end;
// -----------------------------------------------------------------------------
function GetURLFromFile(const Filename: string; var URL: string): boolean;
var
URLfile : TStringList;
i : integer;
s : string;
p : PChar;
begin
Result := False;
URLfile := TStringList.Create;
try
URLFile.LoadFromFile(Filename);
i := 0;
while (i < URLFile.Count-1) do
begin
if (CompareText(URLFile[i], '[InternetShortcut]') = 0) then
begin
inc(i);
while (i < URLFile.Count) do
begin
s := URLFile[i];
p := PChar(s);
if (StrLIComp(p, 'URL=', length('URL=')) = 0) then
begin
inc(p, length('URL='));
URL := p;
Result := True;
exit;
end else
if (p^ = '[') then
exit;
inc(i);
end;
end;
inc(i);
end;
finally
URLFile.Free;
end;
end;
// -----------------------------------------------------------------------------
// TDropURLTarget
// -----------------------------------------------------------------------------
constructor TDropURLTarget.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DragTypes := [dtLink]; //Only allow links.
GetDataOnEnter := true;
with URLFormatEtc do
begin
cfFormat := CF_URL;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
with FileContentsFormatEtc do
begin
cfFormat := CF_FILECONTENTS;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := 0;
tymed := TYMED_HGLOBAL;
end;
with FGDFormatEtc do
begin
cfFormat := CF_FILEGROUPDESCRIPTOR;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
end;
// -----------------------------------------------------------------------------
//This demonstrates how to enumerate all DataObject formats.
function TDropURLTarget.HasValidFormats: boolean;
var
GetNum, GotNum: longint;
FormatEnumerator: IEnumFormatEtc;
tmpFormatEtc: TformatEtc;
begin
result := false;
//Enumerate available DataObject formats
//to see if any one of the wanted formats is available...
if (DataObject.EnumFormatEtc(DATADIR_GET,FormatEnumerator) <> S_OK) or
(FormatEnumerator.Reset <> S_OK) then
exit;
GetNum := 1; //get one at a time...
while (FormatEnumerator.Next(GetNum, tmpFormatEtc, @GotNum) = S_OK) and
(GetNum = GotNum) do
with tmpFormatEtc do
if (ptd = nil) and (dwAspect = DVASPECT_CONTENT) and
{(lindex <> -1) or} (tymed and TYMED_HGLOBAL <> 0) and
((cfFormat = CF_URL) or (cfFormat = CF_FILECONTENTS) or
(cfFormat = CF_HDROP) or (cfFormat = CF_TEXT)) then
begin
result := true;
break;
end;
end;
// -----------------------------------------------------------------------------
procedure TDropURLTarget.ClearData;
begin
fURL := '';
end;
// -----------------------------------------------------------------------------
function TDropURLTarget.DoGetData: boolean;
var
medium: TStgMedium;
cText: pchar;
tmpFiles: TStringList;
pFGD: PFileGroupDescriptor;
begin
fURL := '';
fTitle := '';
result := false;
//--------------------------------------------------------------------------
if (DataObject.GetData(URLFormatEtc, medium) = S_OK) then
begin
try
if (medium.tymed <> TYMED_HGLOBAL) then
exit;
cText := PChar(GlobalLock(medium.HGlobal));
fURL := cText;
GlobalUnlock(medium.HGlobal);
result := true;
finally
ReleaseStgMedium(medium);
end;
end
//--------------------------------------------------------------------------
else if (DataObject.GetData(TextFormatEtc, medium) = S_OK) then
begin
try
if (medium.tymed <> TYMED_HGLOBAL) then
exit;
cText := PChar(GlobalLock(medium.HGlobal));
fURL := cText;
GlobalUnlock(medium.HGlobal);
result := true;
finally
ReleaseStgMedium(medium);
end;
end
//--------------------------------------------------------------------------
else if (DataObject.GetData(FileContentsFormatEtc, medium) = S_OK) then
begin
try
if (medium.tymed <> TYMED_HGLOBAL) then
exit;
cText := PChar(GlobalLock(medium.HGlobal));
fURL := cText;
fURL := copy(fURL,24,250);
GlobalUnlock(medium.HGlobal);
result := true;
finally
ReleaseStgMedium(medium);
end;
end
//--------------------------------------------------------------------------
else if (DataObject.GetData(HDropFormatEtc, medium) = S_OK) then
begin
try
if (medium.tymed <> TYMED_HGLOBAL) then exit;
tmpFiles := TStringList.create;
try
if GetFilesFromHGlobal(medium.HGlobal,TStrings(tmpFiles)) and
(lowercase(ExtractFileExt(tmpFiles[0])) = '.url') and
GetURLFromFile(tmpFiles[0], fURL) then
begin
fTitle := extractfilename(tmpFiles[0]);
delete(fTitle,length(fTitle)-3,4); //deletes '.url' extension
result := true;
end;
finally
tmpFiles.free;
end;
finally
ReleaseStgMedium(medium);
end;
end;
if (DataObject.GetData(FGDFormatEtc, medium) = S_OK) then
begin
try
if (medium.tymed <> TYMED_HGLOBAL) then exit;
pFGD := pointer(GlobalLock(medium.HGlobal));
fTitle := pFGD^.fgd[0].cFileName;
GlobalUnlock(medium.HGlobal);
delete(fTitle,length(fTitle)-3,4); //deletes '.url' extension
finally
ReleaseStgMedium(medium);
end;
end
else if fTitle = '' then fTitle := fURL;
end;
// -----------------------------------------------------------------------------
// -----------------------------------------------------------------------------
end.