Subversion Repositories decoder

Rev

Blame | Last modification | View Log | RSS feed

  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.  
  1270.