unit DropURLSource;
// -----------------------------------------------------------------------------
// Project: Drag and Drop Component Suite
// Component Names: TDropURLSource
// Module: DropURLSource
// Description: Implements Dragging & Dropping of URLs
// FROM your application to 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,
Classes, ActiveX;
{$include DragDrop.inc}
type
TDropURLSource = class(TDropSource)
private
fURL: String;
fTitle: String;
protected
function DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT; Override;
public
constructor Create(aOwner: TComponent); Override;
function CutOrCopyToClipboard: boolean; Override;
published
property URL: String Read fURL Write fURL;
property Title: String Read fTitle Write fTitle;
end;
procedure Register;
implementation
uses
Windows,
SysUtils,
ClipBrd,
ShlObj;
procedure Register;
begin
RegisterComponents('DragDrop', [TDropURLSource]);
end;
// -----------------------------------------------------------------------------
function ConvertURLToFilename(url: string): string;
const
Invalids = '\/:?*<>,|''"';
var
i: integer;
begin
if lowercase(copy(url,1,7)) = 'http://' then
url := copy(url,8,128) // limit to 120 chars.
else if lowercase(copy(url,1,6)) = 'ftp://' then
url := copy(url,7,127)
else if lowercase(copy(url,1,7)) = 'mailto:' then
url := copy(url,8,128)
else if lowercase(copy(url,1,5)) = 'file:' then
url := copy(url,6,126);
if url = '' then url := 'untitled';
result := url;
for i := 1 to length(result) do
if result[i] = '/'then
begin
result := copy(result,1,i-1);
break;
end
else if pos(result[i],Invalids) <> 0 then
result[i] := ' ';
appendstr(result,'.url');
end;
// -----------------------------------------------------------------------------
// TDropURLSource
// -----------------------------------------------------------------------------
constructor TDropURLSource.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
fURL := '';
fTitle := '';
DragTypes := [dtLink]; // Only dtLink allowed
AddFormatEtc(CF_URL, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
AddFormatEtc(CF_FILEGROUPDESCRIPTOR, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
AddFormatEtc(CF_FILECONTENTS, NIL, DVASPECT_CONTENT, 0, TYMED_HGLOBAL);
AddFormatEtc(CF_TEXT, NIL, DVASPECT_CONTENT, -1, TYMED_HGLOBAL);
end;
// -----------------------------------------------------------------------------
function TDropURLSource.CutOrCopyToClipboard: boolean;
var
FormatEtcIn: TFormatEtc;
Medium: TStgMedium;
begin
result := false;
FormatEtcIn.cfFormat := CF_URL;
FormatEtcIn.dwAspect := DVASPECT_CONTENT;
FormatEtcIn.tymed := TYMED_HGLOBAL;
if fURL = '' then exit;
if GetData(formatetcIn,Medium) = S_OK then
begin
Clipboard.SetAsHandle(CF_URL,Medium.hGlobal);
result := true;
end else exit;
//render several formats...
FormatEtcIn.cfFormat := CF_TEXT;
FormatEtcIn.dwAspect := DVASPECT_CONTENT;
FormatEtcIn.tymed := TYMED_HGLOBAL;
if GetData(formatetcIn,Medium) = S_OK then
begin
Clipboard.SetAsHandle(CF_TEXT,Medium.hGlobal);
result := true;
end;
end;
// -----------------------------------------------------------------------------
function TDropURLSource.DoGetData(const FormatEtcIn: TFormatEtc; OUT Medium: TStgMedium):HRESULT;
const
URLPrefix = '[InternetShortcut]'#10'URL=';
var
pFGD: PFileGroupDescriptor;
pText: PChar;
begin
Medium.tymed := 0;
Medium.UnkForRelease := NIL;
Medium.hGlobal := 0;
//--------------------------------------------------------------------------
if ((FormatEtcIn.cfFormat = CF_URL) or (FormatEtcIn.cfFormat = CF_TEXT)) and
(FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
(FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
begin
Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, Length(fURL)+1);
if (Medium.hGlobal = 0) then
result := E_OUTOFMEMORY
else
begin
medium.tymed := TYMED_HGLOBAL;
pText := PChar(GlobalLock(Medium.hGlobal));
try
StrCopy(pText, PChar(fURL));
finally
GlobalUnlock(Medium.hGlobal);
end;
result := S_OK;
end;
end
//--------------------------------------------------------------------------
else if (FormatEtcIn.cfFormat = CF_FILECONTENTS) and
(FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
(FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
begin
Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, Length(URLPrefix + fURL)+1);
if (Medium.hGlobal = 0) then
result := E_OUTOFMEMORY
else
begin
medium.tymed := TYMED_HGLOBAL;
pText := PChar(GlobalLock(Medium.hGlobal));
try
StrCopy(pText, PChar(URLPrefix + fURL));
finally
GlobalUnlock(Medium.hGlobal);
end;
result := S_OK;
end;
end
//--------------------------------------------------------------------------
else if (FormatEtcIn.cfFormat = CF_FILEGROUPDESCRIPTOR) and
(FormatEtcIn.dwAspect = DVASPECT_CONTENT) and
(FormatEtcIn.tymed and TYMED_HGLOBAL <> 0) then
begin
Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GHND, SizeOf(TFileGroupDescriptor));
if (Medium.hGlobal = 0) then
begin
result := E_OUTOFMEMORY;
Exit;
end;
medium.tymed := TYMED_HGLOBAL;
pFGD := pointer(GlobalLock(Medium.hGlobal));
try
with pFGD^ do
begin
cItems := 1;
fgd[0].dwFlags := FD_LINKUI;
if title = '' then
StrPCopy(fgd[0].cFileName,ConvertURLToFilename(fURL))
else
StrPCopy(fgd[0].cFileName,ConvertURLToFilename(fTitle));
end;
finally
GlobalUnlock(Medium.hGlobal);
end;
result := S_OK;
//--------------------------------------------------------------------------
end else
result := DV_E_FORMATETC;
end;
// -----------------------------------------------------------------------------
// -----------------------------------------------------------------------------
end.