WebSVN – decoder – Blame – /trunk/VCL_DRAGDROP/DragDropInternet.pas

Rev	Author	Line No.	Line
2	daniel-mar	1	unit DragDropInternet;
		2
		3	// -----------------------------------------------------------------------------
		4	// Project: Drag and Drop Component Suite.
		5	// Module: DragDropInternet
		6	// Description: Implements Dragging and Dropping of internet related data.
		7	// Version: 4.0
		8	// Date: 18-MAY-2001
		9	// Target: Win32, Delphi 5-6
		10	// Authors: Anders Melander, anders@melander.dk, http://www.melander.dk
		11	// Copyright � 1997-2001 Angus Johnson & Anders Melander
		12	// -----------------------------------------------------------------------------
		13
		14	interface
		15
		16	uses
		17	DragDrop,
		18	DropTarget,
		19	DropSource,
		20	DragDropFormats,
		21	Windows,
		22	Classes,
		23	ActiveX;
		24
		25	type
		26
		27	////////////////////////////////////////////////////////////////////////////////
		28	//
		29	// TURLClipboardFormat
		30	//
		31	////////////////////////////////////////////////////////////////////////////////
		32	// Implements support for the 'UniformResourceLocator' format.
		33	////////////////////////////////////////////////////////////////////////////////
		34
		35	TURLClipboardFormat = class(TCustomTextClipboardFormat)
		36	public
		37	function GetClipboardFormat: TClipFormat; override;
		38	property URL: string read GetString write SetString;
		39	end;
		40
		41	////////////////////////////////////////////////////////////////////////////////
		42	//
		43	// TNetscapeBookmarkClipboardFormat
		44	//
		45	////////////////////////////////////////////////////////////////////////////////
		46	// Implements support for the 'Netscape Bookmark' format.
		47	////////////////////////////////////////////////////////////////////////////////
		48	TNetscapeBookmarkClipboardFormat = class(TCustomSimpleClipboardFormat)
		49	private
		50	FURL : string;
		51	FTitle : string;
		52	protected
		53	function ReadData(Value: pointer; Size: integer): boolean; override;
		54	function WriteData(Value: pointer; Size: integer): boolean; override;
		55	function GetSize: integer; override;
		56	public
		57	function GetClipboardFormat: TClipFormat; override;
		58	procedure Clear; override;
		59	property URL: string read FURL write FURL;
		60	property Title: string read FTitle write FTitle;
		61	end;
		62
		63	////////////////////////////////////////////////////////////////////////////////
		64	//
		65	// TNetscapeImageClipboardFormat
		66	//
		67	////////////////////////////////////////////////////////////////////////////////
		68	// Implements support for the 'Netscape Image Format' format.
		69	////////////////////////////////////////////////////////////////////////////////
		70	TNetscapeImageClipboardFormat = class(TCustomSimpleClipboardFormat)
		71	private
		72	FURL : string;
		73	FTitle : string;
		74	FImage : string;
		75	FLowRes : string;
		76	FExtra : string;
		77	FHeight : integer;
		78	FWidth : integer;
		79	protected
		80	function ReadData(Value: pointer; Size: integer): boolean; override;
		81	function WriteData(Value: pointer; Size: integer): boolean; override;
		82	function GetSize: integer; override;
		83	public
		84	function GetClipboardFormat: TClipFormat; override;
		85	procedure Clear; override;
		86	property URL: string read FURL write FURL;
		87	property Title: string read FTitle write FTitle;
		88	property Image: string read FImage write FImage;
		89	property LowRes: string read FLowRes write FLowRes;
		90	property Extra: string read FExtra write FExtra;
		91	property Height: integer read FHeight write FHeight;
		92	property Width: integer read FWidth write FWidth;
		93	end;
		94
		95	////////////////////////////////////////////////////////////////////////////////
		96	//
		97	// TVCardClipboardFormat
		98	//
		99	////////////////////////////////////////////////////////////////////////////////
		100	// Implements support for the '+//ISBN 1-887687-00-9::versit::PDI//vCard'
		101	// (vCard) format.
		102	////////////////////////////////////////////////////////////////////////////////
		103	TVCardClipboardFormat = class(TCustomStringListClipboardFormat)
		104	protected
		105	function ReadData(Value: pointer; Size: integer): boolean; override;
		106	function WriteData(Value: pointer; Size: integer): boolean; override;
		107	function GetSize: integer; override;
		108	public
		109	function GetClipboardFormat: TClipFormat; override;
		110	property Items: TStrings read GetLines;
		111	end;
		112
		113	////////////////////////////////////////////////////////////////////////////////
		114	//
		115	// THTMLClipboardFormat
		116	//
		117	////////////////////////////////////////////////////////////////////////////////
		118	// Implements support for the 'HTML Format' format.
		119	////////////////////////////////////////////////////////////////////////////////
		120	THTMLClipboardFormat = class(TCustomStringListClipboardFormat)
		121	public
		122	function GetClipboardFormat: TClipFormat; override;
		123	function HasData: boolean; override;
		124	function Assign(Source: TCustomDataFormat): boolean; override;
		125	function AssignTo(Dest: TCustomDataFormat): boolean; override;
		126	property HTML: TStrings read GetLines;
		127	end;
		128
		129	////////////////////////////////////////////////////////////////////////////////
		130	//
		131	// TRFC822ClipboardFormat
		132	//
		133	////////////////////////////////////////////////////////////////////////////////
		134	TRFC822ClipboardFormat = class(TCustomStringListClipboardFormat)
		135	public
		136	function GetClipboardFormat: TClipFormat; override;
		137	function Assign(Source: TCustomDataFormat): boolean; override;
		138	function AssignTo(Dest: TCustomDataFormat): boolean; override;
		139	property Text: TStrings read GetLines;
		140	end;
		141
		142
		143	////////////////////////////////////////////////////////////////////////////////
		144	//
		145	// TURLDataFormat
		146	//
		147	////////////////////////////////////////////////////////////////////////////////
		148	// Renderer for URL formats.
		149	////////////////////////////////////////////////////////////////////////////////
		150	TURLDataFormat = class(TCustomDataFormat)
		151	private
		152	FURL : string;
		153	FTitle : string;
		154	procedure SetTitle(const Value: string);
		155	procedure SetURL(const Value: string);
		156	protected
		157	public
		158	function Assign(Source: TClipboardFormat): boolean; override;
		159	function AssignTo(Dest: TClipboardFormat): boolean; override;
		160	procedure Clear; override;
		161	function HasData: boolean; override;
		162	function NeedsData: boolean; override;
		163	property URL: string read FURL write SetURL;
		164	property Title: string read FTitle write SetTitle;
		165	end;
		166
		167
		168	////////////////////////////////////////////////////////////////////////////////
		169	//
		170	// THTMLDataFormat
		171	//
		172	////////////////////////////////////////////////////////////////////////////////
		173	// Renderer for HTML text data.
		174	////////////////////////////////////////////////////////////////////////////////
		175	THTMLDataFormat = class(TCustomDataFormat)
		176	private
		177	FHTML: TStrings;
		178	procedure SetHTML(const Value: TStrings);
		179	protected
		180	public
		181	constructor Create(AOwner: TDragDropComponent); override;
		182	destructor Destroy; override;
		183	function Assign(Source: TClipboardFormat): boolean; override;
		184	function AssignTo(Dest: TClipboardFormat): boolean; override;
		185	procedure Clear; override;
		186	function HasData: boolean; override;
		187	function NeedsData: boolean; override;
		188	property HTML: TStrings read FHTML write SetHTML;
		189	end;
		190
		191
		192	////////////////////////////////////////////////////////////////////////////////
		193	//
		194	// TOutlookMailDataFormat
		195	//
		196	////////////////////////////////////////////////////////////////////////////////
		197	// Renderer for Microsoft Outlook email formats.
		198	////////////////////////////////////////////////////////////////////////////////
		199	(*
		200	TOutlookMessage = class;
		201
		202	TOutlookAttachments = class(TObject)
		203	public
		204	property Attachments[Index: integer]: TOutlookMessage; default;
		205	property Count: integer;
		206	end;
		207
		208	TOutlookMessage = class(TObject)
		209	public
		210	property Text: string;
		211	property Stream: IStream;
		212	property Attachments: TOutlookAttachments;
		213	end;
		214	*)
		215	TOutlookMailDataFormat = class(TCustomDataFormat)
		216	private
		217	FStorages : TStorageInterfaceList;
		218	protected
		219	public
		220	constructor Create(AOwner: TDragDropComponent); override;
		221	destructor Destroy; override;
		222	function Assign(Source: TClipboardFormat): boolean; override;
		223	function AssignTo(Dest: TClipboardFormat): boolean; override;
		224	procedure Clear; override;
		225	function HasData: boolean; override;
		226	function NeedsData: boolean; override;
		227	property Storages: TStorageInterfaceList read FStorages;
		228	// property Streams: TStreamInterfaceList;
		229	// property Messages: TOutlookAttachments;
		230	end;
		231
		232
		233	////////////////////////////////////////////////////////////////////////////////
		234	//
		235	// TDropURLTarget
		236	//
		237	////////////////////////////////////////////////////////////////////////////////
		238	// URL drop target component.
		239	////////////////////////////////////////////////////////////////////////////////
		240	TDropURLTarget = class(TCustomDropMultiTarget)
		241	private
		242	FURLFormat : TURLDataFormat;
		243	protected
		244	function GetTitle: string;
		245	function GetURL: string;
		246	function GetPreferredDropEffect: LongInt; override;
		247	public
		248	constructor Create(AOwner: TComponent); override;
		249	destructor Destroy; override;
		250	property URL: string read GetURL;
		251	property Title: string read GetTitle;
		252	end;
		253
		254	////////////////////////////////////////////////////////////////////////////////
		255	//
		256	// TDropURLSource
		257	//
		258	////////////////////////////////////////////////////////////////////////////////
		259	// URL drop source component.
		260	////////////////////////////////////////////////////////////////////////////////
		261	TDropURLSource = class(TCustomDropMultiSource)
		262	private
		263	FURLFormat : TURLDataFormat;
		264	procedure SetTitle(const Value: string);
		265	procedure SetURL(const Value: string);
		266	protected
		267	function GetTitle: string;
		268	function GetURL: string;
		269	public
		270	constructor Create(AOwner: TComponent); override;
		271	destructor Destroy; override;
		272	published
		273	property URL: string read GetURL write SetURL;
		274	property Title: string read GetTitle write SetTitle;
		275	end;
		276
		277
		278	////////////////////////////////////////////////////////////////////////////////
		279	//
		280	// Component registration
		281	//
		282	////////////////////////////////////////////////////////////////////////////////
		283	procedure Register;
		284
		285	////////////////////////////////////////////////////////////////////////////////
		286	//
		287	// Misc.
		288	//
		289	////////////////////////////////////////////////////////////////////////////////
		290	function GetURLFromFile(const Filename: string; var URL: string): boolean;
		291	function GetURLFromStream(Stream: TStream; var URL: string): boolean;
		292	function ConvertURLToFilename(const url: string): string;
		293
		294	function IsHTML(const s: string): boolean;
		295	function MakeHTML(const s: string): string;
		296
		297
		298	////////////////////////////////////////////////////////////////////////////////
		299	////////////////////////////////////////////////////////////////////////////////
		300	//
		301	// IMPLEMENTATION
		302	//
		303	////////////////////////////////////////////////////////////////////////////////
		304	////////////////////////////////////////////////////////////////////////////////
		305	implementation
		306
		307	uses
		308	SysUtils,
		309	ShlObj,
		310	DragDropFile,
		311	DragDropPIDL;
		312
		313	////////////////////////////////////////////////////////////////////////////////
		314	//
		315	// Component registration
		316	//
		317	////////////////////////////////////////////////////////////////////////////////
		318	procedure Register;
		319	begin
		320	RegisterComponents(DragDropComponentPalettePage, [TDropURLTarget,
		321	TDropURLSource]);
		322	end;
		323
		324
		325	////////////////////////////////////////////////////////////////////////////////
		326	//
		327	// Utilities
		328	//
		329	////////////////////////////////////////////////////////////////////////////////
		330	function GetURLFromFile(const Filename: string; var URL: string): boolean;
		331	var
		332	Stream : TStream;
		333	begin
		334	Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
		335	try
		336	Result := GetURLFromStream(Stream, URL);
		337	finally
		338	Stream.Free;
		339	end;
		340	end;
		341
		342	function GetURLFromString(const s: string; var URL: string): boolean;
		343	var
		344	Stream : TMemoryStream;
		345	begin
		346	Stream := TMemoryStream.Create;
		347	try
		348	Stream.Size := Length(s);
		349	Move(PChar(s)^, Stream.Memory^, Length(s));
		350	Result := GetURLFromStream(Stream, URL);
		351	finally
		352	Stream.Free;
		353	end;
		354	end;
		355
		356	const
		357	// * DO NOT LOCALIZE *
		358	InternetShortcut = '[InternetShortcut]';
		359	InternetShortcutExt = '.url';
		360
		361	function GetURLFromStream(Stream: TStream; var URL: string): boolean;
		362	var
		363	URLfile : TStringList;
		364	i : integer;
		365	s : string;
		366	p : PChar;
		367	begin
		368	Result := False;
		369	URLfile := TStringList.Create;
		370	try
		371	URLFile.LoadFromStream(Stream);
		372	i := 0;
		373	while (i < URLFile.Count-1) do
		374	begin
		375	if (CompareText(URLFile[i], InternetShortcut) = 0) then
		376	begin
		377	inc(i);
		378	while (i < URLFile.Count) do
		379	begin
		380	s := URLFile[i];
		381	p := PChar(s);
		382	if (StrLIComp(p, 'URL=', length('URL=')) = 0) then
		383	begin
		384	inc(p, length('URL='));
		385	URL := p;
		386	Result := True;
		387	exit;
		388	end else
		389	if (p^ = '[') then
		390	exit;
		391	inc(i);
		392	end;
		393	end;
		394	inc(i);
		395	end;
		396	finally
		397	URLFile.Free;
		398	end;
		399	end;
		400
		401	function ConvertURLToFilename(const url: string): string;
		402	const
		403	Invalids : set of char
		404	= ['\', '/', ':', '?', '*', '<', '>', ',', '\|', '''', '"'];
		405	var
		406	i: integer;
		407	LastInvalid: boolean;
		408	begin
		409	Result := url;
		410	if (AnsiStrLIComp(PChar(lowercase(Result)), 'http://', 7) = 0) then
		411	delete(Result, 1, 7)
		412	else if (AnsiStrLIComp(PChar(lowercase(Result)), 'ftp://', 6) = 0) then
		413	delete(Result, 1, 6)
		414	else if (AnsiStrLIComp(PChar(lowercase(Result)), 'mailto:', 7) = 0) then
		415	delete(Result, 1, 7)
		416	else if (AnsiStrLIComp(PChar(lowercase(Result)), 'file:', 5) = 0) then
		417	delete(Result, 1, 5);
		418
		419	if (length(Result) > 120) then
		420	SetLength(Result, 120);
		421
		422	// Truncate at first slash
		423	i := pos('/', Result);
		424	if (i > 0) then
		425	SetLength(Result, i-1);
		426
		427	// Replace invalids with spaces.
		428	// If string starts with invalids, they are trimmed.
		429	LastInvalid := True;
		430	for i := length(Result) downto 1 do
		431	if (Result[i] in Invalids) then
		432	begin
		433	if (not LastInvalid) then
		434	begin
		435	Result[i] := ' ';
		436	LastInvalid := True;
		437	end else
		438	// Repeating invalids are trimmed.
		439	Delete(Result, i, 1);
		440	end else
		441	LastInvalid := False;
		442
		443	if Result = '' then
		444	Result := 'untitled';
		445
		446	Result := Result+InternetShortcutExt;
		447	end;
		448
		449	function IsHTML(const s: string): boolean;
		450	begin
		451	Result := (pos('<HTML>', Uppercase(s)) > 0);
		452	end;
		453
		454	function MakeHTML(const s: string): string;
		455	begin
		456	{ TODO -oanme -cImprovement : Needs to escape special chars in text to HTML conversion. }
		457	{ TODO -oanme -cImprovement : Needs better text to HTML conversion. }
		458	if (not IsHTML(s)) then
		459	Result := '<HTML>'#13#10'<BODY>'#13#10 + s + #13#10'</BODY>'#13#10'</HTML>'
		460	else
		461	Result := s;
		462	end;
		463
		464
		465	////////////////////////////////////////////////////////////////////////////////
		466	//
		467	// TURLClipboardFormat
		468	//
		469	////////////////////////////////////////////////////////////////////////////////
		470	var
		471	CF_URL: TClipFormat = 0;
		472
		473	function TURLClipboardFormat.GetClipboardFormat: TClipFormat;
		474	begin
		475	if (CF_URL = 0) then
		476	CF_URL := RegisterClipboardFormat(CFSTR_SHELLURL);
		477	Result := CF_URL;
		478	end;
		479
		480
		481	////////////////////////////////////////////////////////////////////////////////
		482	//
		483	// TNetscapeBookmarkClipboardFormat
		484	//
		485	////////////////////////////////////////////////////////////////////////////////
		486	var
		487	CF_NETSCAPEBOOKMARK: TClipFormat = 0;
		488
		489	function TNetscapeBookmarkClipboardFormat.GetClipboardFormat: TClipFormat;
		490	begin
		491	if (CF_NETSCAPEBOOKMARK = 0) then
		492	CF_NETSCAPEBOOKMARK := RegisterClipboardFormat('Netscape Bookmark'); // * DO NOT LOCALIZE *
		493	Result := CF_NETSCAPEBOOKMARK;
		494	end;
		495
		496	function TNetscapeBookmarkClipboardFormat.GetSize: integer;
		497	begin
		498	Result := 0;
		499	if (FURL <> '') then
		500	begin
		501	inc(Result, 1024);
		502	if (FTitle <> '') then
		503	inc(Result, 1024);
		504	end;
		505	end;
		506
		507	function TNetscapeBookmarkClipboardFormat.ReadData(Value: pointer;
		508	Size: integer): boolean;
		509	begin
		510	// Note: No check for missing string terminator!
		511	FURL := PChar(Value);
		512	if (Size > 1024) then
		513	begin
		514	inc(PChar(Value), 1024);
		515	FTitle := PChar(Value);
		516	end;
		517	Result := True;
		518	end;
		519
		520	function TNetscapeBookmarkClipboardFormat.WriteData(Value: pointer;
		521	Size: integer): boolean;
		522	begin
		523	StrLCopy(Value, PChar(FURL), Size);
		524	dec(Size, 1024);
		525	if (Size > 0) and (FTitle <> '') then
		526	begin
		527	inc(PChar(Value), 1024);
		528	StrLCopy(Value, PChar(FTitle), Size);
		529	end;
		530	Result := True;
		531	end;
		532
		533	procedure TNetscapeBookmarkClipboardFormat.Clear;
		534	begin
		535	FURL := '';
		536	FTitle := '';
		537	end;
		538
		539
		540	////////////////////////////////////////////////////////////////////////////////
		541	//
		542	// TNetscapeImageClipboardFormat
		543	//
		544	////////////////////////////////////////////////////////////////////////////////
		545	var
		546	CF_NETSCAPEIMAGE: TClipFormat = 0;
		547
		548	function TNetscapeImageClipboardFormat.GetClipboardFormat: TClipFormat;
		549	begin
		550	if (CF_NETSCAPEIMAGE = 0) then
		551	CF_NETSCAPEIMAGE := RegisterClipboardFormat('Netscape Image Format');
		552	Result := CF_NETSCAPEIMAGE;
		553	end;
		554
		555	type
		556	TNetscapeImageRec = record
		557	Size ,
		558	_Unknown1 ,
		559	Width ,
		560	Height ,
		561	HorMargin ,
		562	VerMargin ,
		563	Border ,
		564	OfsLowRes ,
		565	OfsTitle ,
		566	OfsURL ,
		567	OfsExtra : DWORD
		568	end;
		569	PNetscapeImageRec = ^TNetscapeImageRec;
		570
		571	function TNetscapeImageClipboardFormat.GetSize: integer;
		572	begin
		573	Result := SizeOf(TNetscapeImageRec);
		574	inc(Result, Length(FImage)+1);
		575
		576	if (FLowRes <> '') then
		577	inc(Result, Length(FLowRes)+1);
		578	if (FTitle <> '') then
		579	inc(Result, Length(FTitle)+1);
		580	if (FUrl <> '') then
		581	inc(Result, Length(FUrl)+1);
		582	if (FExtra <> '') then
		583	inc(Result, Length(FExtra)+1);
		584	end;
		585
		586	function TNetscapeImageClipboardFormat.ReadData(Value: pointer;
		587	Size: integer): boolean;
		588	begin
		589	Result := (Size > SizeOf(TNetscapeImageRec));
		590	if (Result) then
		591	begin
		592	FWidth := PNetscapeImageRec(Value)^.Width;
		593	FHeight := PNetscapeImageRec(Value)^.Height;
		594	FImage := PChar(Value) + SizeOf(TNetscapeImageRec);
		595	if (PNetscapeImageRec(Value)^.OfsLowRes <> 0) then
		596	FLowRes := PChar(Value) + PNetscapeImageRec(Value)^.OfsLowRes;
		597	if (PNetscapeImageRec(Value)^.OfsTitle <> 0) then
		598	FTitle := PChar(Value) + PNetscapeImageRec(Value)^.OfsTitle;
		599	if (PNetscapeImageRec(Value)^.OfsURL <> 0) then
		600	FUrl := PChar(Value) + PNetscapeImageRec(Value)^.OfsUrl;
		601	if (PNetscapeImageRec(Value)^.OfsExtra <> 0) then
		602	FExtra := PChar(Value) + PNetscapeImageRec(Value)^.OfsExtra;
		603	end;
		604	end;
		605
		606	function TNetscapeImageClipboardFormat.WriteData(Value: pointer;
		607	Size: integer): boolean;
		608	var
		609	NetscapeImageRec : PNetscapeImageRec;
		610	begin
		611	Result := (Size > SizeOf(TNetscapeImageRec));
		612	if (Result) then
		613	begin
		614	NetscapeImageRec := PNetscapeImageRec(Value);
		615	NetscapeImageRec^.Width := FWidth;
		616	NetscapeImageRec^.Height := FHeight;
		617	inc(PChar(Value), SizeOf(TNetscapeImageRec));
		618	dec(Size, SizeOf(TNetscapeImageRec));
		619	StrLCopy(Value, PChar(FImage), Size);
		620	dec(Size, Length(FImage)+1);
		621	if (Size <= 0) then
		622	exit;
		623	if (FLowRes <> '') then
		624	begin
		625	StrLCopy(Value, PChar(FLowRes), Size);
		626	NetscapeImageRec^.OfsLowRes := integer(Value) - integer(NetscapeImageRec);
		627	dec(Size, Length(FLowRes)+1);
		628	inc(PChar(Value), Length(FLowRes)+1);
		629	if (Size <= 0) then
		630	exit;
		631	end;
		632	if (FTitle <> '') then
		633	begin
		634	StrLCopy(Value, PChar(FTitle), Size);
		635	NetscapeImageRec^.OfsTitle := integer(Value) - integer(NetscapeImageRec);
		636	dec(Size, Length(FTitle)+1);
		637	inc(PChar(Value), Length(FTitle)+1);
		638	if (Size <= 0) then
		639	exit;
		640	end;
		641	if (FUrl <> '') then
		642	begin
		643	StrLCopy(Value, PChar(FUrl), Size);
		644	NetscapeImageRec^.OfsUrl := integer(Value) - integer(NetscapeImageRec);
		645	dec(Size, Length(FUrl)+1);
		646	inc(PChar(Value), Length(FUrl)+1);
		647	if (Size <= 0) then
		648	exit;
		649	end;
		650	if (FExtra <> '') then
		651	begin
		652	StrLCopy(Value, PChar(FExtra), Size);
		653	NetscapeImageRec^.OfsExtra := integer(Value) - integer(NetscapeImageRec);
		654	dec(Size, Length(FExtra)+1);
		655	inc(PChar(Value), Length(FExtra)+1);
		656	if (Size <= 0) then
		657	exit;
		658	end;
		659	end;
		660	end;
		661
		662	procedure TNetscapeImageClipboardFormat.Clear;
		663	begin
		664	FURL := '';
		665	FTitle := '';
		666	FImage := '';
		667	FLowRes := '';
		668	FExtra := '';
		669	FHeight := 0;
		670	FWidth := 0;
		671	end;
		672
		673
		674	////////////////////////////////////////////////////////////////////////////////
		675	//
		676	// TVCardClipboardFormat
		677	//
		678	////////////////////////////////////////////////////////////////////////////////
		679	var
		680	CF_VCARD: TClipFormat = 0;
		681
		682	function TVCardClipboardFormat.GetClipboardFormat: TClipFormat;
		683	begin
		684	if (CF_VCARD = 0) then
		685	CF_VCARD := RegisterClipboardFormat('+//ISBN 1-887687-00-9::versit::PDI//vCard'); // * DO NOT LOCALIZE *
		686	Result := CF_VCARD;
		687	end;
		688
		689	function TVCardClipboardFormat.GetSize: integer;
		690	var
		691	i : integer;
		692	begin
		693	if (Items.Count > 0) then
		694	begin
		695	Result := 22; // Length('begin:vcard'+#13+'end:vcard'+#0);
		696	for i := 0 to Items.Count-1 do
		697	inc(Result, Length(Items[i])+1);
		698	end else
		699	Result := 0;
		700	end;
		701
		702	function TVCardClipboardFormat.ReadData(Value: pointer; Size: integer): boolean;
		703	var
		704	i : integer;
		705	s : string;
		706	begin
		707	Result := inherited ReadData(Value, Size);
		708	if (Result) then
		709	begin
		710	// Zap vCard header and trailer
		711	if (Items.Count > 0) and (CompareText(Items[0], 'begin:vcard') = 0) then
		712	Items.Delete(0);
		713	if (Items.Count > 0) and (CompareText(Items[Items.Count-1], 'end:vcard') = 0) then
		714	Items.Delete(Items.Count-1);
		715	// Convert to item/value list
		716	for i := 0 to Items.Count-1 do
		717	if (pos(':', Items[i]) > 0) then
		718	begin
		719	s := Items[i];
		720	s[pos(':', Items[i])] := '=';
		721	Items[i] := s;
		722	end;
		723	end;
		724	end;
		725
		726	function DOSStringToUnixString(dos: string): string;
		727	var
		728	s, d : PChar;
		729	l : integer;
		730	begin
		731	SetLength(Result, Length(dos)+1);
		732	s := PChar(dos);
		733	d := PChar(Result);
		734	l := 1;
		735	while (s^ <> #0) do
		736	begin
		737	// Ignore LF
		738	if (s^ <> #10) then
		739	begin
		740	d^ := s^;
		741	inc(l);
		742	inc(d);
		743	end;
		744	inc(s);
		745	end;
		746	SetLength(Result, l);
		747	end;
		748
		749	function TVCardClipboardFormat.WriteData(Value: pointer; Size: integer): boolean;
		750	var
		751	s : string;
		752	begin
		753	Result := (Items.Count > 0);
		754	if (Result) then
		755	begin
		756	s := DOSStringToUnixString('begin:vcard'+#13+Items.Text+#13+'end:vcard');
		757	StrLCopy(Value, PChar(s), Size);
		758	end;
		759	end;
		760
		761
		762	////////////////////////////////////////////////////////////////////////////////
		763	//
		764	// THTMLClipboardFormat
		765	//
		766	////////////////////////////////////////////////////////////////////////////////
		767	var
		768	CF_HTML: TClipFormat = 0;
		769
		770	function THTMLClipboardFormat.GetClipboardFormat: TClipFormat;
		771	begin
		772	if (CF_HTML = 0) then
		773	CF_HTML := RegisterClipboardFormat('HTML Format');
		774	Result := CF_HTML;
		775	end;
		776
		777	function THTMLClipboardFormat.HasData: boolean;
		778	begin
		779	Result := inherited HasData and IsHTML(HTML.Text);
		780	end;
		781
		782	function THTMLClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
		783	begin
		784	Result := True;
		785	if (Source is TTextDataFormat) then
		786	HTML.Text := MakeHTML(TTextDataFormat(Source).Text)
		787	else
		788	Result := inherited Assign(Source);
		789	end;
		790
		791	function THTMLClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
		792	begin
		793	Result := True;
		794	if (Dest is TTextDataFormat) then
		795	TTextDataFormat(Dest).Text := HTML.Text
		796	else
		797	Result := inherited AssignTo(Dest);
		798	end;
		799
		800
		801	////////////////////////////////////////////////////////////////////////////////
		802	//
		803	// TRFC822ClipboardFormat
		804	//
		805	////////////////////////////////////////////////////////////////////////////////
		806	var
		807	CF_RFC822: TClipFormat = 0;
		808
		809	function TRFC822ClipboardFormat.GetClipboardFormat: TClipFormat;
		810	begin
		811	if (CF_RFC822 = 0) then
		812	CF_RFC822 := RegisterClipboardFormat('Internet Message (rfc822/rfc1522)'); // * DO NOT LOCALIZE *
		813	Result := CF_RFC822;
		814	end;
		815
		816	function TRFC822ClipboardFormat.Assign(Source: TCustomDataFormat): boolean;
		817	begin
		818	Result := True;
		819	if (Source is TTextDataFormat) then
		820	Text.Text := TTextDataFormat(Source).Text
		821	else
		822	Result := inherited Assign(Source);
		823	end;
		824
		825	function TRFC822ClipboardFormat.AssignTo(Dest: TCustomDataFormat): boolean;
		826	begin
		827	Result := True;
		828	if (Dest is TTextDataFormat) then
		829	TTextDataFormat(Dest).Text := Text.Text
		830	else
		831	Result := inherited AssignTo(Dest);
		832	end;
		833
		834
		835	////////////////////////////////////////////////////////////////////////////////
		836	//
		837	// TURLDataFormat
		838	//
		839	////////////////////////////////////////////////////////////////////////////////
		840	function TURLDataFormat.Assign(Source: TClipboardFormat): boolean;
		841	var
		842	s : string;
		843	begin
		844	Result := False;
		845	(*
		846	** TURLClipboardFormat
		847	*)
		848	if (Source is TURLClipboardFormat) then
		849	begin
		850	if (FURL = '') then
		851	FURL := TURLClipboardFormat(Source).URL;
		852	Result := True;
		853	end else
		854	(*
		855	** TTextClipboardFormat
		856	*)
		857	if (Source is TTextClipboardFormat) then
		858	begin
		859	if (FURL = '') then
		860	begin
		861	s := TTextClipboardFormat(Source).Text;
		862	// Convert from text if the string looks like an URL
		863	if (pos('://', s) > 1) then
		864	begin
		865	FURL := s;
		866	Result := True;
		867	end;
		868	end;
		869	end else
		870	(*
		871	** TFileClipboardFormat
		872	*)
		873	if (Source is TFileClipboardFormat) then
		874	begin
		875	if (FURL = '') then
		876	begin
		877	s := TFileClipboardFormat(Source).Files[0];
		878	// Convert from Internet Shortcut file format.
		879	if (CompareText(ExtractFileExt(s), InternetShortcutExt) = 0) and
		880	(GetURLFromFile(s, FURL)) then
		881	begin
		882	if (FTitle = '') then
		883	FTitle := ChangeFileExt(ExtractFileName(s), '');
		884	Result := True;
		885	end;
		886	end;
		887	end else
		888	(*
		889	** TFileContentsClipboardFormat
		890	*)
		891	if (Source is TFileContentsClipboardFormat) then
		892	begin
		893	if (FURL = '') then
		894	begin
		895	s := TFileContentsClipboardFormat(Source).Data;
		896	Result := GetURLFromString(s, FURL);
		897	end;
		898	end else
		899	(*
		900	** TFileGroupDescritorClipboardFormat
		901	*)
		902	if (Source is TFileGroupDescritorClipboardFormat) then
		903	begin
		904	if (FTitle = '') then
		905	begin
		906	if (TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.cItems > 0) then
		907	begin
		908	// Extract the title of an Internet Shortcut
		909	s := TFileGroupDescritorClipboardFormat(Source).FileGroupDescriptor^.fgd[0].cFileName;
		910	if (CompareText(ExtractFileExt(s), InternetShortcutExt) = 0) then
		911	begin
		912	FTitle := ChangeFileExt(s, '');
		913	Result := True;
		914	end;
		915	end;
		916	end;
		917	end else
		918	(*
		919	** TNetscapeBookmarkClipboardFormat
		920	*)
		921	if (Source is TNetscapeBookmarkClipboardFormat) then
		922	begin
		923	if (FURL = '') then
		924	FURL := TNetscapeBookmarkClipboardFormat(Source).URL;
		925	if (FTitle = '') then
		926	FTitle := TNetscapeBookmarkClipboardFormat(Source).Title;
		927	Result := True;
		928	end else
		929	(*
		930	** TNetscapeImageClipboardFormat
		931	*)
		932	if (Source is TNetscapeImageClipboardFormat) then
		933	begin
		934	if (FURL = '') then
		935	FURL := TNetscapeImageClipboardFormat(Source).URL;
		936	if (FTitle = '') then
		937	FTitle := TNetscapeImageClipboardFormat(Source).Title;
		938	Result := True;
		939	end else
		940	Result := inherited Assign(Source);
		941	end;
		942
		943	function TURLDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
		944	var
		945	FGD : TFileGroupDescriptor;
		946	s : string;
		947	begin
		948	Result := True;
		949	(*
		950	** TURLClipboardFormat
		951	*)
		952	if (Dest is TURLClipboardFormat) then
		953	begin
		954	TURLClipboardFormat(Dest).URL := FURL;
		955	end else
		956	(*
		957	** TTextClipboardFormat
		958	*)
		959	if (Dest is TTextClipboardFormat) then
		960	begin
		961	TTextClipboardFormat(Dest).Text := FURL;
		962	end else
		963	(*
		964	** TFileContentsClipboardFormat
		965	*)
		966	if (Dest is TFileContentsClipboardFormat) then
		967	begin
		968	TFileContentsClipboardFormat(Dest).Data := InternetShortcut + #13#10 +
		969	'URL='+FURL + #13#10;
		970	end else
		971	(*
		972	** TFileGroupDescritorClipboardFormat
		973	*)
		974	if (Dest is TFileGroupDescritorClipboardFormat) then
		975	begin
		976	FillChar(FGD, SizeOf(FGD), 0);
		977	FGD.cItems := 1;
		978	if (FTitle = '') then
		979	s := FURL
		980	else
		981	s := FTitle;
		982	StrLCopy(@FGD.fgd[0].cFileName[0], PChar(ConvertURLToFilename(s)),
		983	SizeOf(FGD.fgd[0].cFileName));
		984	FGD.fgd[0].dwFlags := FD_LINKUI;
		985	TFileGroupDescritorClipboardFormat(Dest).CopyFrom(@FGD);
		986	end else
		987	(*
		988	** TNetscapeBookmarkClipboardFormat
		989	*)
		990	if (Dest is TNetscapeBookmarkClipboardFormat) then
		991	begin
		992	TNetscapeBookmarkClipboardFormat(Dest).URL := FURL;
		993	TNetscapeBookmarkClipboardFormat(Dest).Title := FTitle;
		994	end else
		995	(*
		996	** TNetscapeImageClipboardFormat
		997	*)
		998	if (Dest is TNetscapeImageClipboardFormat) then
		999	begin
		1000	TNetscapeImageClipboardFormat(Dest).URL := FURL;
		1001	TNetscapeImageClipboardFormat(Dest).Title := FTitle;
		1002	end else
		1003	Result := inherited AssignTo(Dest);
		1004	end;
		1005
		1006	procedure TURLDataFormat.Clear;
		1007	begin
		1008	Changing;
		1009	FURL := '';
		1010	FTitle := '';
		1011	end;
		1012
		1013	procedure TURLDataFormat.SetTitle(const Value: string);
		1014	begin
		1015	Changing;
		1016	FTitle := Value;
		1017	end;
		1018
		1019	procedure TURLDataFormat.SetURL(const Value: string);
		1020	begin
		1021	Changing;
		1022	FURL := Value;
		1023	end;
		1024
		1025	function TURLDataFormat.HasData: boolean;
		1026	begin
		1027	Result := (FURL <> '') or (FTitle <> '');
		1028	end;
		1029
		1030	function TURLDataFormat.NeedsData: boolean;
		1031	begin
		1032	Result := (FURL = '') or (FTitle = '');
		1033	end;
		1034
		1035
		1036	////////////////////////////////////////////////////////////////////////////////
		1037	//
		1038	// THTMLDataFormat
		1039	//
		1040	////////////////////////////////////////////////////////////////////////////////
		1041	function THTMLDataFormat.Assign(Source: TClipboardFormat): boolean;
		1042	begin
		1043	Result := True;
		1044
		1045	if (Source is THTMLClipboardFormat) then
		1046	FHTML.Assign(THTMLClipboardFormat(Source).HTML)
		1047
		1048	else
		1049	Result := inherited Assign(Source);
		1050	end;
		1051
		1052	function THTMLDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
		1053	begin
		1054	Result := True;
		1055
		1056	if (Dest is THTMLClipboardFormat) then
		1057	THTMLClipboardFormat(Dest).HTML.Assign(FHTML)
		1058
		1059	else
		1060	Result := inherited AssignTo(Dest);
		1061	end;
		1062
		1063	procedure THTMLDataFormat.Clear;
		1064	begin
		1065	Changing;
		1066	FHTML.Clear;
		1067	end;
		1068
		1069	constructor THTMLDataFormat.Create(AOwner: TDragDropComponent);
		1070	begin
		1071	inherited Create(AOwner);
		1072	FHTML := TStringList.Create;
		1073	end;
		1074
		1075	destructor THTMLDataFormat.Destroy;
		1076	begin
		1077	FHTML.Free;
		1078	inherited Destroy;
		1079	end;
		1080
		1081	function THTMLDataFormat.HasData: boolean;
		1082	begin
		1083	Result := (FHTML.Count > 0);
		1084	end;
		1085
		1086	function THTMLDataFormat.NeedsData: boolean;
		1087	begin
		1088	Result := (FHTML.Count = 0);
		1089	end;
		1090
		1091	procedure THTMLDataFormat.SetHTML(const Value: TStrings);
		1092	begin
		1093	FHTML.Assign(Value);
		1094	end;
		1095
		1096	////////////////////////////////////////////////////////////////////////////////
		1097	//
		1098	// TOutlookMailDataFormat
		1099	//
		1100	////////////////////////////////////////////////////////////////////////////////
		1101	constructor TOutlookMailDataFormat.Create(AOwner: TDragDropComponent);
		1102	begin
		1103	inherited Create(AOwner);
		1104	FStorages := TStorageInterfaceList.Create;
		1105	FStorages.OnChanging := DoOnChanging;
		1106	end;
		1107
		1108	destructor TOutlookMailDataFormat.Destroy;
		1109	begin
		1110	Clear;
		1111	FStorages.Free;
		1112	inherited Destroy;
		1113	end;
		1114
		1115	procedure TOutlookMailDataFormat.Clear;
		1116	begin
		1117	Changing;
		1118	FStorages.Clear;
		1119	end;
		1120
		1121	function TOutlookMailDataFormat.Assign(Source: TClipboardFormat): boolean;
		1122	begin
		1123	Result := True;
		1124
		1125	if (Source is TFileContentsStorageClipboardFormat) then
		1126	FStorages.Assign(TFileContentsStorageClipboardFormat(Source).Storages)
		1127
		1128	else
		1129	Result := inherited Assign(Source);
		1130	end;
		1131
		1132	function TOutlookMailDataFormat.AssignTo(Dest: TClipboardFormat): boolean;
		1133	begin
		1134	Result := True;
		1135
		1136	if (Dest is TFileContentsStorageClipboardFormat) then
		1137	TFileContentsStorageClipboardFormat(Dest).Storages.Assign(FStorages)
		1138
		1139	else
		1140	Result := inherited AssignTo(Dest);
		1141	end;
		1142
		1143	function TOutlookMailDataFormat.HasData: boolean;
		1144	begin
		1145	Result := (FStorages.Count > 0);
		1146	end;
		1147
		1148	function TOutlookMailDataFormat.NeedsData: boolean;
		1149	begin
		1150	Result := (FStorages.Count = 0);
		1151	end;
		1152
		1153
		1154
		1155	////////////////////////////////////////////////////////////////////////////////
		1156	//
		1157	// TDropURLTarget
		1158	//
		1159	////////////////////////////////////////////////////////////////////////////////
		1160
		1161	constructor TDropURLTarget.Create(AOwner: TComponent);
		1162	begin
		1163	inherited Create(AOwner);
		1164	DragTypes := [dtCopy, dtLink];
		1165	GetDataOnEnter := True;
		1166
		1167	FURLFormat := TURLDataFormat.Create(Self);
		1168	end;
		1169
		1170	destructor TDropURLTarget.Destroy;
		1171	begin
		1172	FURLFormat.Free;
		1173	inherited Destroy;
		1174	end;
		1175
		1176	function TDropURLTarget.GetTitle: string;
		1177	begin
		1178	Result := FURLFormat.Title;
		1179	end;
		1180
		1181	function TDropURLTarget.GetURL: string;
		1182	begin
		1183	Result := FURLFormat.URL;
		1184	end;
		1185
		1186	function TDropURLTarget.GetPreferredDropEffect: LongInt;
		1187	begin
		1188	Result := GetPreferredDropEffect;
		1189	if (Result = DROPEFFECT_NONE) then
		1190	Result := DROPEFFECT_LINK;
		1191	end;
		1192
		1193	////////////////////////////////////////////////////////////////////////////////
		1194	//
		1195	// TDropURLSource
		1196	//
		1197	////////////////////////////////////////////////////////////////////////////////
		1198	constructor TDropURLSource.Create(AOwner: TComponent);
		1199	begin
		1200	inherited Create(AOwner);
		1201	DragTypes := [dtCopy, dtLink];
		1202	PreferredDropEffect := DROPEFFECT_LINK;
		1203
		1204	FURLFormat := TURLDataFormat.Create(Self);
		1205	end;
		1206
		1207	destructor TDropURLSource.Destroy;
		1208	begin
		1209	FURLFormat.Free;
		1210	inherited Destroy;
		1211	end;
		1212
		1213	function TDropURLSource.GetTitle: string;
		1214	begin
		1215	Result := FURLFormat.Title;
		1216	end;
		1217
		1218	procedure TDropURLSource.SetTitle(const Value: string);
		1219	begin
		1220	FURLFormat.Title := Value;
		1221	end;
		1222
		1223	function TDropURLSource.GetURL: string;
		1224	begin
		1225	Result := FURLFormat.URL;
		1226	end;
		1227
		1228	procedure TDropURLSource.SetURL(const Value: string);
		1229	begin
		1230	FURLFormat.URL := Value;
		1231	end;
		1232
		1233
		1234	////////////////////////////////////////////////////////////////////////////////
		1235	//
		1236	// Initialization/Finalization
		1237	//
		1238	////////////////////////////////////////////////////////////////////////////////
		1239	initialization
		1240	// Data format registration
		1241	TURLDataFormat.RegisterDataFormat;
		1242	THTMLDataFormat.RegisterDataFormat;
		1243	// Clipboard format registration
		1244	TURLDataFormat.RegisterCompatibleFormat(TNetscapeBookmarkClipboardFormat, 0, csSourceTarget, [ddRead]);
		1245	TURLDataFormat.RegisterCompatibleFormat(TNetscapeImageClipboardFormat, 1, csSourceTarget, [ddRead]);
		1246	TURLDataFormat.RegisterCompatibleFormat(TFileContentsClipboardFormat, 2, csSourceTarget, [ddRead]);
		1247	TURLDataFormat.RegisterCompatibleFormat(TFileGroupDescritorClipboardFormat, 2, csSourceTarget, [ddRead]);
		1248	TURLDataFormat.RegisterCompatibleFormat(TURLClipboardFormat, 2, csSourceTarget, [ddRead]);
		1249	TURLDataFormat.RegisterCompatibleFormat(TTextClipboardFormat, 3, csSourceTarget, [ddRead]);
		1250	TURLDataFormat.RegisterCompatibleFormat(TFileClipboardFormat, 4, [csTarget], [ddRead]);
		1251
		1252	THTMLDataFormat.RegisterCompatibleFormat(THTMLClipboardFormat, 0, csSourceTarget, [ddRead]);
		1253
		1254	TTextDataFormat.RegisterCompatibleFormat(TRFC822ClipboardFormat, 1, csSourceTarget, [ddRead]);
		1255	TTextDataFormat.RegisterCompatibleFormat(THTMLClipboardFormat, 2, csSourceTarget, [ddRead]);
		1256
		1257	finalization
		1258	// Clipboard format unregistration
		1259	TNetscapeBookmarkClipboardFormat.UnregisterClipboardFormat;
		1260	TNetscapeImageClipboardFormat.UnregisterClipboardFormat;
		1261	TURLClipboardFormat.UnregisterClipboardFormat;
		1262	TVCardClipboardFormat.UnregisterClipboardFormat;
		1263	THTMLClipboardFormat.UnregisterClipboardFormat;
		1264	TRFC822ClipboardFormat.UnregisterClipboardFormat;
		1265
		1266	// Target format unregistration
		1267	TURLDataFormat.UnregisterDataFormat;
		1268	end.
		1269

Subversion Repositories decoder

decoder/trunk/VCL_DRAGDROP/DragDropInternet.pas – Rev 2