Subversion Repositories decoder

Compare Revisions

Regard whitespace Rev 1 → Rev 2

/trunk/VCL_DRAGDROP/DragDropInternet.pas
0,0 → 1,1269
unit DragDropInternet;
 
// -----------------------------------------------------------------------------
// Project: Drag and Drop Component Suite.
// Module: DragDropInternet
// Description: Implements Dragging and Dropping of internet related data.
// Version: 4.0
// Date: 18-MAY-2001
// Target: Win32, Delphi 5-6
// Authors: Anders Melander, anders@melander.dk, http://www.melander.dk
// Copyright © 1997-2001 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
 
interface
 
uses
DragDrop,
DropTarget,
DropSource,
DragDropFormats,
Windows,
Classes,
ActiveX;
 
type
 
////////////////////////////////////////////////////////////////////////////////
//
// TURLClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Implements support for the 'UniformResourceLocator' format.
////////////////////////////////////////////////////////////////////////////////
 
TURLClipboardFormat = class(TCustomTextClipboardFormat)
public
function GetClipboardFormat: TClipFormat; override;
property URL: string read GetString write SetString;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TNetscapeBookmarkClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Implements support for the 'Netscape Bookmark' format.
////////////////////////////////////////////////////////////////////////////////
TNetscapeBookmarkClipboardFormat = class(TCustomSimpleClipboardFormat)
private
FURL : string;
FTitle : string;
protected
function ReadData(Value: pointer; Size: integer): boolean; override;
function WriteData(Value: pointer; Size: integer): boolean; override;
function GetSize: integer; override;
public
function GetClipboardFormat: TClipFormat; override;
procedure Clear; override;
property URL: string read FURL write FURL;
property Title: string read FTitle write FTitle;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TNetscapeImageClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Implements support for the 'Netscape Image Format' format.
////////////////////////////////////////////////////////////////////////////////
TNetscapeImageClipboardFormat = class(TCustomSimpleClipboardFormat)
private
FURL : string;
FTitle : string;
FImage : string;
FLowRes : string;
FExtra : string;
FHeight : integer;
FWidth : integer;
protected
function ReadData(Value: pointer; Size: integer): boolean; override;
function WriteData(Value: pointer; Size: integer): boolean; override;
function GetSize: integer; override;
public
function GetClipboardFormat: TClipFormat; override;
procedure Clear; override;
property URL: string read FURL write FURL;
property Title: string read FTitle write FTitle;
property Image: string read FImage write FImage;
property LowRes: string read FLowRes write FLowRes;
property Extra: string read FExtra write FExtra;
property Height: integer read FHeight write FHeight;
property Width: integer read FWidth write FWidth;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TVCardClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Implements support for the '+//ISBN 1-887687-00-9::versit::PDI//vCard'
// (vCard) format.
////////////////////////////////////////////////////////////////////////////////
TVCardClipboardFormat = class(TCustomStringListClipboardFormat)
protected
function ReadData(Value: pointer; Size: integer): boolean; override;
function WriteData(Value: pointer; Size: integer): boolean; override;
function GetSize: integer; override;
public
function GetClipboardFormat: TClipFormat; override;
property Items: TStrings read GetLines;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// THTMLClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
// Implements support for the 'HTML Format' format.
////////////////////////////////////////////////////////////////////////////////
THTMLClipboardFormat = class(TCustomStringListClipboardFormat)
public
function GetClipboardFormat: TClipFormat; override;
function HasData: boolean; override;
function Assign(Source: TCustomDataFormat): boolean; override;
function AssignTo(Dest: TCustomDataFormat): boolean; override;
property HTML: TStrings read GetLines;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TRFC822ClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
TRFC822ClipboardFormat = class(TCustomStringListClipboardFormat)
public
function GetClipboardFormat: TClipFormat; override;
function Assign(Source: TCustomDataFormat): boolean; override;
function AssignTo(Dest: TCustomDataFormat): boolean; override;
property Text: TStrings read GetLines;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TURLDataFormat
//
////////////////////////////////////////////////////////////////////////////////
// Renderer for URL formats.
////////////////////////////////////////////////////////////////////////////////
TURLDataFormat = class(TCustomDataFormat)
private
FURL : string;
FTitle : string;
procedure SetTitle(const Value: string);
procedure SetURL(const Value: string);
protected
public
function Assign(Source: TClipboardFormat): boolean; override;
function AssignTo(Dest: TClipboardFormat): boolean; override;
procedure Clear; override;
function HasData: boolean; override;
function NeedsData: boolean; override;
property URL: string read FURL write SetURL;
property Title: string read FTitle write SetTitle;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// THTMLDataFormat
//
////////////////////////////////////////////////////////////////////////////////
// Renderer for HTML text data.
////////////////////////////////////////////////////////////////////////////////
THTMLDataFormat = class(TCustomDataFormat)
private
FHTML: TStrings;
procedure SetHTML(const Value: TStrings);
protected
public
constructor Create(AOwner: TDragDropComponent); override;
destructor Destroy; override;
function Assign(Source: TClipboardFormat): boolean; override;
function AssignTo(Dest: TClipboardFormat): boolean; override;
procedure Clear; override;
function HasData: boolean; override;
function NeedsData: boolean; override;
property HTML: TStrings read FHTML write SetHTML;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TOutlookMailDataFormat
//
////////////////////////////////////////////////////////////////////////////////
// Renderer for Microsoft Outlook email formats.
////////////////////////////////////////////////////////////////////////////////
(*
TOutlookMessage = class;
 
TOutlookAttachments = class(TObject)
public
property Attachments[Index: integer]: TOutlookMessage; default;
property Count: integer;
end;
 
TOutlookMessage = class(TObject)
public
property Text: string;
property Stream: IStream;
property Attachments: TOutlookAttachments;
end;
*)
TOutlookMailDataFormat = class(TCustomDataFormat)
private
FStorages : TStorageInterfaceList;
protected
public
constructor Create(AOwner: TDragDropComponent); override;
destructor Destroy; override;
function Assign(Source: TClipboardFormat): boolean; override;
function AssignTo(Dest: TClipboardFormat): boolean; override;
procedure Clear; override;
function HasData: boolean; override;
function NeedsData: boolean; override;
property Storages: TStorageInterfaceList read FStorages;
// property Streams: TStreamInterfaceList;
// property Messages: TOutlookAttachments;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TDropURLTarget
//
////////////////////////////////////////////////////////////////////////////////
// URL drop target component.
////////////////////////////////////////////////////////////////////////////////
TDropURLTarget = class(TCustomDropMultiTarget)
private
FURLFormat : TURLDataFormat;
protected
function GetTitle: string;
function GetURL: string;
function GetPreferredDropEffect: LongInt; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property URL: string read GetURL;
property Title: string read GetTitle;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TDropURLSource
//
////////////////////////////////////////////////////////////////////////////////
// URL drop source component.
////////////////////////////////////////////////////////////////////////////////
TDropURLSource = class(TCustomDropMultiSource)
private
FURLFormat : TURLDataFormat;
procedure SetTitle(const Value: string);
procedure SetURL(const Value: string);
protected
function GetTitle: string;
function GetURL: string;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property URL: string read GetURL write SetURL;
property Title: string read GetTitle write SetTitle;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;
 
////////////////////////////////////////////////////////////////////////////////
//
// Misc.
//
////////////////////////////////////////////////////////////////////////////////
function GetURLFromFile(const Filename: string; var URL: string): boolean;
function GetURLFromStream(Stream: TStream; var URL: string): boolean;
function ConvertURLToFilename(const url: string): string;
 
function IsHTML(const s: string): boolean;
function MakeHTML(const s: string): string;
 
 
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
// IMPLEMENTATION
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
implementation
 
uses
SysUtils,
ShlObj,
DragDropFile,
DragDropPIDL;
 
////////////////////////////////////////////////////////////////////////////////
//
// Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;
begin
RegisterComponents(DragDropComponentPalettePage, [TDropURLTarget,
TDropURLSource]);
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// Utilities
//
////////////////////////////////////////////////////////////////////////////////
function GetURLFromFile(const Filename: string; var URL: string): boolean;
var
Stream : TStream;
begin
Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
try
Result := GetURLFromStream(Stream, URL);
finally
Stream.Free;
end;
end;
 
function GetURLFromString(const s: string; var URL: string): boolean;
var
Stream : TMemoryStream;
begin
Stream := TMemoryStream.Create;
try
Stream.Size := Length(s);
Move(PChar(s)^, Stream.Memory^, Length(s));
Result := GetURLFromStream(Stream, URL);
finally
Stream.Free;
end;
end;
 
const
// *** DO NOT LOCALIZE ***
InternetShortcut = '[InternetShortcut]';
InternetShortcutExt = '.url';
 
function GetURLFromStream(Stream: TStream; var URL: string): boolean;
var
URLfile : TStringList;
i : integer;
s : string;
p : PChar;
begin
Result := False;
URLfile := TStringList.Create;
try
URLFile.LoadFromStream(Stream);
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;
 
function ConvertURLToFilename(const url: string): string;
const
Invalids : set of char
= ['\', '/', ':', '?', '*', '<', '>', ',', '|', '''', '"'];
var
i: integer;
LastInvalid: boolean;
begin
Result := url;
if (AnsiStrLIComp(PChar(lowercase(Result)), 'http://', 7) = 0) then
delete(Result, 1, 7)
else if (AnsiStrLIComp(PChar(lowercase(Result)), 'ftp://', 6) = 0) then
delete(Result, 1, 6)
else if (AnsiStrLIComp(PChar(lowercase(Result)), 'mailto:', 7) = 0) then
delete(Result, 1, 7)
else if (AnsiStrLIComp(PChar(lowercase(Result)), 'file:', 5) = 0) then
delete(Result, 1, 5);
 
if (length(Result) > 120) then
SetLength(Result, 120);
 
// Truncate at first slash
i := pos('/', Result);
if (i > 0) then
SetLength(Result, i-1);
 
// Replace invalids with spaces.
// If string starts with invalids, they are trimmed.
LastInvalid := True;
for i := length(Result) downto 1 do
if (Result[i] in Invalids) then
begin
if (not LastInvalid) then
begin
Result[i] := ' ';
LastInvalid := True;
end else
// Repeating invalids are trimmed.
Delete(Result, i, 1);
end else
LastInvalid := False;
 
if Result = '' then
Result := 'untitled';
 
Result := Result+InternetShortcutExt;
end;
 
function IsHTML(const s: string): boolean;
begin
Result := (pos('<HTML>', Uppercase(s)) > 0);
end;
 
function MakeHTML(const s: string): string;
begin
{ TODO -oanme -cImprovement : Needs to escape special chars in text to HTML conversion. }
{ TODO -oanme -cImprovement : Needs better text to HTML conversion. }
if (not IsHTML(s)) then
Result := '<HTML>'#13#10'<BODY>'#13#10 + s + #13#10'</BODY>'#13#10'</HTML>'
else
Result := s;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TURLClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
var
CF_URL: TClipFormat = 0;
 
function TURLClipboardFormat.GetClipboardFormat: TClipFormat;
begin
if (CF_URL = 0) then
CF_URL := RegisterClipboardFormat(CFSTR_SHELLURL);
Result := CF_URL;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TNetscapeBookmarkClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
var
CF_NETSCAPEBOOKMARK: TClipFormat = 0;
 
function TNetscapeBookmarkClipboardFormat.GetClipboardFormat: TClipFormat;
begin
if (CF_NETSCAPEBOOKMARK = 0) then
CF_NETSCAPEBOOKMARK := RegisterClipboardFormat('Netscape Bookmark'); // *** DO NOT LOCALIZE ***
Result := CF_NETSCAPEBOOKMARK;
end;
 
function TNetscapeBookmarkClipboardFormat.GetSize: integer;
begin
Result := 0;
if (FURL <> '') then
begin
inc(Result, 1024);
if (FTitle <> '') then
inc(Result, 1024);
end;
end;
 
function TNetscapeBookmarkClipboardFormat.ReadData(Value: pointer;
Size: integer): boolean;
begin
// Note: No check for missing string terminator!
FURL := PChar(Value);
if (Size > 1024) then
begin
inc(PChar(Value), 1024);
FTitle := PChar(Value);
end;
Result := True;
end;
 
function TNetscapeBookmarkClipboardFormat.WriteData(Value: pointer;
Size: integer): boolean;
begin
StrLCopy(Value, PChar(FURL), Size);
dec(Size, 1024);
if (Size > 0) and (FTitle <> '') then
begin
inc(PChar(Value), 1024);
StrLCopy(Value, PChar(FTitle), Size);
end;
Result := True;
end;
 
procedure TNetscapeBookmarkClipboardFormat.Clear;
begin
FURL := '';
FTitle := '';
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TNetscapeImageClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
var
CF_NETSCAPEIMAGE: TClipFormat = 0;
 
function TNetscapeImageClipboardFormat.GetClipboardFormat: TClipFormat;
begin
if (CF_NETSCAPEIMAGE = 0) then
CF_NETSCAPEIMAGE := RegisterClipboardFormat('Netscape Image Format');
Result := CF_NETSCAPEIMAGE;
end;
 
type
TNetscapeImageRec = record
Size ,
_Unknown1 ,
Width ,
Height ,
HorMargin ,
VerMargin ,
Border ,
OfsLowRes ,
OfsTitle ,
OfsURL ,
OfsExtra : DWORD
end;
PNetscapeImageRec = ^TNetscapeImageRec;
 
function TNetscapeImageClipboardFormat.GetSize: integer;
begin
Result := SizeOf(TNetscapeImageRec);
inc(Result, Length(FImage)+1);
 
if (FLowRes <> '') then
inc(Result, Length(FLowRes)+1);
if (FTitle <> '') then
inc(Result, Length(FTitle)+1);
if (FUrl <> '') then
inc(Result, Length(FUrl)+1);
if (FExtra <> '') then
inc(Result, Length(FExtra)+1);
end;
 
function TNetscapeImageClipboardFormat.ReadData(Value: pointer;
Size: integer): boolean;
begin
Result := (Size > SizeOf(TNetscapeImageRec));
if (Result) then
begin
FWidth := PNetscapeImageRec(Value)^.Width;
FHeight := PNetscapeImageRec(Value)^.Height;
FImage := PChar(Value) + SizeOf(TNetscapeImageRec);
if (PNetscapeImageRec(Value)^.OfsLowRes <> 0) then
FLowRes := PChar(Value) + PNetscapeImageRec(Value)^.OfsLowRes;
if (PNetscapeImageRec(Value)^.OfsTitle <> 0) then
FTitle := PChar(Value) + PNetscapeImageRec(Value)^.OfsTitle;
if (PNetscapeImageRec(Value)^.OfsURL <> 0) then
FUrl := PChar(Value) + PNetscapeImageRec(Value)^.OfsUrl;
if (PNetscapeImageRec(Value)^.OfsExtra <> 0) then
FExtra := PChar(Value) + PNetscapeImageRec(Value)^.OfsExtra;
end;
end;
 
function TNetscapeImageClipboardFormat.WriteData(Value: pointer;
Size: integer): boolean;
var
NetscapeImageRec : PNetscapeImageRec;
begin
Result := (Size > SizeOf(TNetscapeImageRec));
if (Result) then
begin
NetscapeImageRec := PNetscapeImageRec(Value);
NetscapeImageRec^.Width := FWidth;
NetscapeImageRec^.Height := FHeight;
inc(PChar(Value), SizeOf(TNetscapeImageRec));
dec(Size, SizeOf(TNetscapeImageRec));
StrLCopy(Value, PChar(FImage), Size);
dec(Size, Length(FImage)+1);
if (Size <= 0) then
exit;
if (FLowRes <> '') then
begin
StrLCopy(Value, PChar(FLowRes), Size);
NetscapeImageRec^.OfsLowRes := integer(Value) - integer(NetscapeImageRec);
dec(Size, Length(FLowRes)+1);
inc(PChar(Value), Length(FLowRes)+1);
if (Size <= 0) then
exit;
end;
if (FTitle <> '') then
begin
StrLCopy(Value, PChar(FTitle), Size);
NetscapeImageRec^.OfsTitle := integer(Value) - integer(NetscapeImageRec);
dec(Size, Length(FTitle)+1);
inc(PChar(Value), Length(FTitle)+1);
if (Size <= 0) then
exit;
end;
if (FUrl <> '') then
begin
StrLCopy(Value, PChar(FUrl), Size);
NetscapeImageRec^.OfsUrl := integer(Value) - integer(NetscapeImageRec);
dec(Size, Length(FUrl)+1);
inc(PChar(Value), Length(FUrl)+1);
if (Size <= 0) then
exit;
end;
if (FExtra <> '') then
begin
StrLCopy(Value, PChar(FExtra), Size);
NetscapeImageRec^.OfsExtra := integer(Value) - integer(NetscapeImageRec);
dec(Size, Length(FExtra)+1);
inc(PChar(Value), Length(FExtra)+1);
if (Size <= 0) then
exit;
end;
end;
end;
 
procedure TNetscapeImageClipboardFormat.Clear;
begin
FURL := '';
FTitle := '';
FImage := '';
FLowRes := '';
FExtra := '';
FHeight := 0;
FWidth := 0;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TVCardClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
var
CF_VCARD: TClipFormat = 0;
 
function TVCardClipboardFormat.GetClipboardFormat: TClipFormat;
begin
if (CF_VCARD = 0) then
CF_VCARD := RegisterClipboardFormat('+//ISBN 1-887687-00-9::versit::PDI//vCard'); // *** DO NOT LOCALIZE ***
Result := CF_VCARD;
end;
 
function TVCardClipboardFormat.GetSize: integer;
var
i : integer;
begin
if (Items.Count > 0) then
begin
Result := 22; // Length('begin:vcard'+#13+'end:vcard'+#0);
for i := 0 to Items.Count-1 do
inc(Result, Length(Items[i])+1);
end else
Result := 0;
end;
 
function TVCardClipboardFormat.ReadData(Value: pointer; Size: integer): boolean;
var
i : integer;
s : string;
begin
Result := inherited ReadData(Value, Size);
if (Result) then
begin
// Zap vCard header and trailer
if (Items.Count > 0) and (CompareText(Items[0], 'begin:vcard') = 0) then
Items.Delete(0);
if (Items.Count > 0) and (CompareText(Items[Items.Count-1], 'end:vcard') = 0) then
Items.Delete(Items.Count-1);
// Convert to item/value list
for i := 0 to Items.Count-1 do
if (pos(':', Items[i]) > 0) then
begin
s := Items[i];
s[pos(':', Items[i])] := '=';
Items[i] := s;
end;
end;
end;
 
function DOSStringToUnixString(dos: string): string;
var
s, d : PChar;
l : integer;
begin
SetLength(Result, Length(dos)+1);
s := PChar(dos);
d := PChar(Result);
l := 1;
while (s^ <> #0) do
begin
// Ignore LF
if (s^ <> #10) then
begin
d^ := s^;
inc(l);
inc(d);
end;
inc(s);
end;
SetLength(Result, l);
end;
 
function TVCardClipboardFormat.WriteData(Value: pointer; Size: integer): boolean;
var
s : string;
begin
Result := (Items.Count > 0);
if (Result) then
begin
s := DOSStringToUnixString('begin:vcard'+#13+Items.Text+#13+'end:vcard');
StrLCopy(Value, PChar(s), Size);
end;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// THTMLClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
var
CF_HTML: TClipFormat = 0;
 
function THTMLClipboardFormat.GetClipboardFormat: TClipFormat;
begin
if (CF_HTML = 0) then
CF_HTML := RegisterClipboardFormat('HTML Format');
Result := CF_HTML;
end;
 
function THTMLClipboardFormat.HasData: boolean;
begin
Result := inherited HasData and IsHTML(HTML.Text);
end;
 
function THTMLClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
begin
Result := True;
if (Source is TTextDataFormat) then
HTML.Text := MakeHTML(TTextDataFormat(Source).Text)
else
Result := inherited Assign(Source);
end;
 
function THTMLClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
begin
Result := True;
if (Dest is TTextDataFormat) then
TTextDataFormat(Dest).Text := HTML.Text
else
Result := inherited AssignTo(Dest);
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TRFC822ClipboardFormat
//
////////////////////////////////////////////////////////////////////////////////
var
CF_RFC822: TClipFormat = 0;
 
function TRFC822ClipboardFormat.GetClipboardFormat: TClipFormat;
begin
if (CF_RFC822 = 0) then
CF_RFC822 := RegisterClipboardFormat('Internet Message (rfc822/rfc1522)'); // *** DO NOT LOCALIZE ***
Result := CF_RFC822;
end;
 
function TRFC822ClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
begin
Result := True;
if (Source is TTextDataFormat) then
Text.Text := TTextDataFormat(Source).Text
else
Result := inherited Assign(Source);
end;
 
function TRFC822ClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
begin
Result := True;
if (Dest is TTextDataFormat) then
TTextDataFormat(Dest).Text := Text.Text
else
Result := inherited AssignTo(Dest);
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TURLDataFormat
//
////////////////////////////////////////////////////////////////////////////////
function TURLDataFormat.Assign(Source: TClipboardFormat): boolean;
var
s : string;
begin
Result := False;
(*
** TURLClipboardFormat
*)
if (Source is TURLClipboardFormat) then
begin
if (FURL = '') then
FURL := TURLClipboardFormat(Source).URL;
Result := True;
end else
(*
** TTextClipboardFormat
*)
if (Source is TTextClipboardFormat) then
begin
if (FURL = '') then
begin
s := TTextClipboardFormat(Source).Text;
// Convert from text if the string looks like an URL
if (pos('://', s) > 1) then
begin
FURL := s;
Result := True;
end;
end;
end else
(*
** TFileClipboardFormat
*)
if (Source is TFileClipboardFormat) then
begin
if (FURL = '') then
begin
s := TFileClipboardFormat(Source).Files[0];
// Convert from Internet Shortcut file format.
if (CompareText(ExtractFileExt(s), InternetShortcutExt) = 0) and
(GetURLFromFile(s, FURL)) then
begin
if (FTitle = '') then
FTitle := ChangeFileExt(ExtractFileName(s), '');
Result := True;
end;
end;
end else
(*
** TFileContentsClipboardFormat
*)
if (Source is TFileContentsClipboardFormat) then
begin
if (FURL = '') then
begin
s := TFileContentsClipboardFormat(Source).Data;
Result := GetURLFromString(s, FURL);
end;
end else
(*
** TFileGroupDescritorClipboardFormat
*)
if (Source is TFileGroupDescritorClipboardFormat) then
begin
if (FTitle = '') then
begin
if (TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.cItems > 0) then
begin
// Extract the title of an Internet Shortcut
s := TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.fgd[0].cFileName;
if (CompareText(ExtractFileExt(s), InternetShortcutExt) = 0) then
begin
FTitle := ChangeFileExt(s, '');
Result := True;
end;
end;
end;
end else
(*
** TNetscapeBookmarkClipboardFormat
*)
if (Source is TNetscapeBookmarkClipboardFormat) then
begin
if (FURL = '') then
FURL := TNetscapeBookmarkClipboardFormat(Source).URL;
if (FTitle = '') then
FTitle := TNetscapeBookmarkClipboardFormat(Source).Title;
Result := True;
end else
(*
** TNetscapeImageClipboardFormat
*)
if (Source is TNetscapeImageClipboardFormat) then
begin
if (FURL = '') then
FURL := TNetscapeImageClipboardFormat(Source).URL;
if (FTitle = '') then
FTitle := TNetscapeImageClipboardFormat(Source).Title;
Result := True;
end else
Result := inherited Assign(Source);
end;
 
function TURLDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
var
FGD : TFileGroupDescriptor;
s : string;
begin
Result := True;
(*
** TURLClipboardFormat
*)
if (Dest is TURLClipboardFormat) then
begin
TURLClipboardFormat(Dest).URL := FURL;
end else
(*
** TTextClipboardFormat
*)
if (Dest is TTextClipboardFormat) then
begin
TTextClipboardFormat(Dest).Text := FURL;
end else
(*
** TFileContentsClipboardFormat
*)
if (Dest is TFileContentsClipboardFormat) then
begin
TFileContentsClipboardFormat(Dest).Data := InternetShortcut + #13#10 +
'URL='+FURL + #13#10;
end else
(*
** TFileGroupDescritorClipboardFormat
*)
if (Dest is TFileGroupDescritorClipboardFormat) then
begin
FillChar(FGD, SizeOf(FGD), 0);
FGD.cItems := 1;
if (FTitle = '') then
s := FURL
else
s := FTitle;
StrLCopy(@FGD.fgd[0].cFileName[0], PChar(ConvertURLToFilename(s)),
SizeOf(FGD.fgd[0].cFileName));
FGD.fgd[0].dwFlags := FD_LINKUI;
TFileGroupDescritorClipboardFormat(Dest).CopyFrom(@FGD);
end else
(*
** TNetscapeBookmarkClipboardFormat
*)
if (Dest is TNetscapeBookmarkClipboardFormat) then
begin
TNetscapeBookmarkClipboardFormat(Dest).URL := FURL;
TNetscapeBookmarkClipboardFormat(Dest).Title := FTitle;
end else
(*
** TNetscapeImageClipboardFormat
*)
if (Dest is TNetscapeImageClipboardFormat) then
begin
TNetscapeImageClipboardFormat(Dest).URL := FURL;
TNetscapeImageClipboardFormat(Dest).Title := FTitle;
end else
Result := inherited AssignTo(Dest);
end;
 
procedure TURLDataFormat.Clear;
begin
Changing;
FURL := '';
FTitle := '';
end;
 
procedure TURLDataFormat.SetTitle(const Value: string);
begin
Changing;
FTitle := Value;
end;
 
procedure TURLDataFormat.SetURL(const Value: string);
begin
Changing;
FURL := Value;
end;
 
function TURLDataFormat.HasData: boolean;
begin
Result := (FURL <> '') or (FTitle <> '');
end;
 
function TURLDataFormat.NeedsData: boolean;
begin
Result := (FURL = '') or (FTitle = '');
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// THTMLDataFormat
//
////////////////////////////////////////////////////////////////////////////////
function THTMLDataFormat.Assign(Source: TClipboardFormat): boolean;
begin
Result := True;
 
if (Source is THTMLClipboardFormat) then
FHTML.Assign(THTMLClipboardFormat(Source).HTML)
 
else
Result := inherited Assign(Source);
end;
 
function THTMLDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
begin
Result := True;
 
if (Dest is THTMLClipboardFormat) then
THTMLClipboardFormat(Dest).HTML.Assign(FHTML)
 
else
Result := inherited AssignTo(Dest);
end;
 
procedure THTMLDataFormat.Clear;
begin
Changing;
FHTML.Clear;
end;
 
constructor THTMLDataFormat.Create(AOwner: TDragDropComponent);
begin
inherited Create(AOwner);
FHTML := TStringList.Create;
end;
 
destructor THTMLDataFormat.Destroy;
begin
FHTML.Free;
inherited Destroy;
end;
 
function THTMLDataFormat.HasData: boolean;
begin
Result := (FHTML.Count > 0);
end;
 
function THTMLDataFormat.NeedsData: boolean;
begin
Result := (FHTML.Count = 0);
end;
 
procedure THTMLDataFormat.SetHTML(const Value: TStrings);
begin
FHTML.Assign(Value);
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TOutlookMailDataFormat
//
////////////////////////////////////////////////////////////////////////////////
constructor TOutlookMailDataFormat.Create(AOwner: TDragDropComponent);
begin
inherited Create(AOwner);
FStorages := TStorageInterfaceList.Create;
FStorages.OnChanging := DoOnChanging;
end;
 
destructor TOutlookMailDataFormat.Destroy;
begin
Clear;
FStorages.Free;
inherited Destroy;
end;
 
procedure TOutlookMailDataFormat.Clear;
begin
Changing;
FStorages.Clear;
end;
 
function TOutlookMailDataFormat.Assign(Source: TClipboardFormat): boolean;
begin
Result := True;
 
if (Source is TFileContentsStorageClipboardFormat) then
FStorages.Assign(TFileContentsStorageClipboardFormat(Source).Storages)
 
else
Result := inherited Assign(Source);
end;
 
function TOutlookMailDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
begin
Result := True;
 
if (Dest is TFileContentsStorageClipboardFormat) then
TFileContentsStorageClipboardFormat(Dest).Storages.Assign(FStorages)
 
else
Result := inherited AssignTo(Dest);
end;
 
function TOutlookMailDataFormat.HasData: boolean;
begin
Result := (FStorages.Count > 0);
end;
 
function TOutlookMailDataFormat.NeedsData: boolean;
begin
Result := (FStorages.Count = 0);
end;
 
 
 
////////////////////////////////////////////////////////////////////////////////
//
// TDropURLTarget
//
////////////////////////////////////////////////////////////////////////////////
 
constructor TDropURLTarget.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DragTypes := [dtCopy, dtLink];
GetDataOnEnter := True;
 
FURLFormat := TURLDataFormat.Create(Self);
end;
 
destructor TDropURLTarget.Destroy;
begin
FURLFormat.Free;
inherited Destroy;
end;
 
function TDropURLTarget.GetTitle: string;
begin
Result := FURLFormat.Title;
end;
 
function TDropURLTarget.GetURL: string;
begin
Result := FURLFormat.URL;
end;
 
function TDropURLTarget.GetPreferredDropEffect: LongInt;
begin
Result := GetPreferredDropEffect;
if (Result = DROPEFFECT_NONE) then
Result := DROPEFFECT_LINK;
end;
 
////////////////////////////////////////////////////////////////////////////////
//
// TDropURLSource
//
////////////////////////////////////////////////////////////////////////////////
constructor TDropURLSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DragTypes := [dtCopy, dtLink];
PreferredDropEffect := DROPEFFECT_LINK;
 
FURLFormat := TURLDataFormat.Create(Self);
end;
 
destructor TDropURLSource.Destroy;
begin
FURLFormat.Free;
inherited Destroy;
end;
 
function TDropURLSource.GetTitle: string;
begin
Result := FURLFormat.Title;
end;
 
procedure TDropURLSource.SetTitle(const Value: string);
begin
FURLFormat.Title := Value;
end;
 
function TDropURLSource.GetURL: string;
begin
Result := FURLFormat.URL;
end;
 
procedure TDropURLSource.SetURL(const Value: string);
begin
FURLFormat.URL := Value;
end;
 
 
////////////////////////////////////////////////////////////////////////////////
//
// Initialization/Finalization
//
////////////////////////////////////////////////////////////////////////////////
initialization
// Data format registration
TURLDataFormat.RegisterDataFormat;
THTMLDataFormat.RegisterDataFormat;
// Clipboard format registration
TURLDataFormat.RegisterCompatibleFormat(TNetscapeBookmarkClipboardFormat, 0, csSourceTarget, [ddRead]);
TURLDataFormat.RegisterCompatibleFormat(TNetscapeImageClipboardFormat, 1, csSourceTarget, [ddRead]);
TURLDataFormat.RegisterCompatibleFormat(TFileContentsClipboardFormat, 2, csSourceTarget, [ddRead]);
TURLDataFormat.RegisterCompatibleFormat(TFileGroupDescritorClipboardFormat, 2, csSourceTarget, [ddRead]);
TURLDataFormat.RegisterCompatibleFormat(TURLClipboardFormat, 2, csSourceTarget, [ddRead]);
TURLDataFormat.RegisterCompatibleFormat(TTextClipboardFormat, 3, csSourceTarget, [ddRead]);
TURLDataFormat.RegisterCompatibleFormat(TFileClipboardFormat, 4, [csTarget], [ddRead]);
 
THTMLDataFormat.RegisterCompatibleFormat(THTMLClipboardFormat, 0, csSourceTarget, [ddRead]);
 
TTextDataFormat.RegisterCompatibleFormat(TRFC822ClipboardFormat, 1, csSourceTarget, [ddRead]);
TTextDataFormat.RegisterCompatibleFormat(THTMLClipboardFormat, 2, csSourceTarget, [ddRead]);
 
finalization
// Clipboard format unregistration
TNetscapeBookmarkClipboardFormat.UnregisterClipboardFormat;
TNetscapeImageClipboardFormat.UnregisterClipboardFormat;
TURLClipboardFormat.UnregisterClipboardFormat;
TVCardClipboardFormat.UnregisterClipboardFormat;
THTMLClipboardFormat.UnregisterClipboardFormat;
TRFC822ClipboardFormat.UnregisterClipboardFormat;
 
// Target format unregistration
TURLDataFormat.UnregisterDataFormat;
end.