Subversion Repositories decoder

unit DropURLTarget;

// -----------------------------------------------------------------------------

// Project:         Drag and Drop Component Suite

// Component Names: TDropURLTarget

// Module:          DropURLTarget

// Description:     Implements Dragging & Dropping of URLs

//                  TO your application from another.

// Version:         3.7

// Date:            22-APR-1999

// Target:          Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4

// Authors:         Angus Johnson,   ajohnson@rpi.net.au

//                  Anders Melander, anders@melander.dk

//                                   http://www.melander.dk

// Copyright        © 1997-99 Angus Johnson & Anders Melander

// -----------------------------------------------------------------------------

interface

uses

  DropSource, DropTarget,

  Classes, ActiveX;

{$include DragDrop.inc}

type

  TDropURLTarget = class(TDropTarget)

  private

    URLFormatEtc,

    FileContentsFormatEtc,

    FGDFormatEtc: TFormatEtc;

    fURL: String;

    fTitle: String;

  protected

    procedure ClearData; override;

    function DoGetData: boolean; override;

    function HasValidFormats: boolean; override;

  public

    constructor Create(AOwner: TComponent); override;

    property URL: String Read fURL Write fURL;

    property Title: String Read fTitle Write fTitle;

  end;

procedure Register;

implementation

uses

  Windows,

  SysUtils,

  ShlObj;

procedure Register;

begin

  RegisterComponents('DragDrop', [TDropURLTarget]);

end;

// -----------------------------------------------------------------------------

function GetURLFromFile(const Filename: string; var URL: string): boolean;

var

  URLfile               : TStringList;

  i                     : integer;

  s                     : string;

  p                     : PChar;

begin

  Result := False;

  URLfile := TStringList.Create;

  try

    URLFile.LoadFromFile(Filename);

    i := 0;

    while (i < URLFile.Count-1) do

    begin

      if (CompareText(URLFile[i], '[InternetShortcut]') = 0) then

      begin

        inc(i);

        while (i < URLFile.Count) do

        begin

          s := URLFile[i];

          p := PChar(s);

          if (StrLIComp(p, 'URL=', length('URL=')) = 0) then

          begin

            inc(p, length('URL='));

            URL := p;

            Result := True;

            exit;

          end else

            if (p^ = '[') then

              exit;

          inc(i);

        end;

      end;

      inc(i);

    end;

  finally

    URLFile.Free;

  end;

end;

// -----------------------------------------------------------------------------

//                      TDropURLTarget

// -----------------------------------------------------------------------------

constructor TDropURLTarget.Create(AOwner: TComponent);

begin

  inherited Create(AOwner);

  DragTypes := [dtLink]; //Only allow links.

  GetDataOnEnter := true;

  with URLFormatEtc do

  begin

    cfFormat := CF_URL;

    ptd := nil;

    dwAspect := DVASPECT_CONTENT;

    lindex := -1;

    tymed := TYMED_HGLOBAL;

  end;

  with FileContentsFormatEtc do

  begin

    cfFormat := CF_FILECONTENTS;

    ptd := nil;

    dwAspect := DVASPECT_CONTENT;

    lindex := 0;

    tymed := TYMED_HGLOBAL;

  end;

  with FGDFormatEtc do

  begin

    cfFormat := CF_FILEGROUPDESCRIPTOR;

    ptd := nil;

    dwAspect := DVASPECT_CONTENT;

    lindex := -1;

    tymed := TYMED_HGLOBAL;

  end;

end;

// ----------------------------------------------------------------------------- 

//This demonstrates how to enumerate all DataObject formats.

function TDropURLTarget.HasValidFormats: boolean;

var

  GetNum, GotNum: longint;

  FormatEnumerator: IEnumFormatEtc;

  tmpFormatEtc: TformatEtc;

begin

  result := false;

  //Enumerate available DataObject formats

  //to see if any one of the wanted formats is available...

  if (DataObject.EnumFormatEtc(DATADIR_GET,FormatEnumerator) <> S_OK) or

     (FormatEnumerator.Reset <> S_OK) then

    exit;

  GetNum := 1; //get one at a time...

  while (FormatEnumerator.Next(GetNum, tmpFormatEtc, @GotNum) = S_OK) and

        (GetNum = GotNum) do

    with tmpFormatEtc do

      if (ptd = nil) and (dwAspect = DVASPECT_CONTENT) and

         {(lindex <> -1) or} (tymed and TYMED_HGLOBAL <> 0) and

         ((cfFormat = CF_URL) or (cfFormat = CF_FILECONTENTS) or

         (cfFormat = CF_HDROP) or (cfFormat = CF_TEXT)) then

      begin

        result := true;

        break;

      end;

end;

// ----------------------------------------------------------------------------- 

procedure TDropURLTarget.ClearData;

begin

  fURL := '';

end;

// ----------------------------------------------------------------------------- 

function TDropURLTarget.DoGetData: boolean;

var

  medium: TStgMedium;

  cText: pchar;

  tmpFiles: TStringList;

  pFGD: PFileGroupDescriptor;

begin

  fURL := '';

  fTitle := '';

  result := false;

  //--------------------------------------------------------------------------

  if (DataObject.GetData(URLFormatEtc, medium) = S_OK) then

  begin

    try

      if (medium.tymed <> TYMED_HGLOBAL) then

        exit;

      cText := PChar(GlobalLock(medium.HGlobal));

      fURL := cText;

      GlobalUnlock(medium.HGlobal);

      result := true;

    finally

      ReleaseStgMedium(medium);

    end;

  end

  //--------------------------------------------------------------------------

  else if (DataObject.GetData(TextFormatEtc, medium) = S_OK) then

  begin

    try

      if (medium.tymed <> TYMED_HGLOBAL) then

        exit;

      cText := PChar(GlobalLock(medium.HGlobal));

      fURL := cText;

      GlobalUnlock(medium.HGlobal);

      result := true;

    finally

      ReleaseStgMedium(medium);

    end;

  end

  //--------------------------------------------------------------------------

  else if (DataObject.GetData(FileContentsFormatEtc, medium) = S_OK) then

  begin

    try

      if (medium.tymed <> TYMED_HGLOBAL) then

        exit;

      cText := PChar(GlobalLock(medium.HGlobal));

      fURL := cText;

      fURL := copy(fURL,24,250);

      GlobalUnlock(medium.HGlobal);

      result := true;

    finally

      ReleaseStgMedium(medium);

    end;

  end

  //--------------------------------------------------------------------------

  else if (DataObject.GetData(HDropFormatEtc, medium) = S_OK) then

  begin

    try

      if (medium.tymed <> TYMED_HGLOBAL) then exit;

      tmpFiles := TStringList.create;

      try

        if GetFilesFromHGlobal(medium.HGlobal,TStrings(tmpFiles)) and

          (lowercase(ExtractFileExt(tmpFiles[0])) = '.url') and

             GetURLFromFile(tmpFiles[0], fURL) then

        begin

            fTitle := extractfilename(tmpFiles[0]);

            delete(fTitle,length(fTitle)-3,4); //deletes '.url' extension

            result := true;

        end;

      finally

        tmpFiles.free;

      end;

    finally

      ReleaseStgMedium(medium);

    end;

  end;

  if (DataObject.GetData(FGDFormatEtc, medium) = S_OK) then

  begin

    try

      if (medium.tymed <> TYMED_HGLOBAL) then exit;

      pFGD := pointer(GlobalLock(medium.HGlobal));

      fTitle := pFGD^.fgd[0].cFileName;

      GlobalUnlock(medium.HGlobal);

      delete(fTitle,length(fTitle)-3,4); //deletes '.url' extension

    finally

      ReleaseStgMedium(medium);

    end;

  end

  else if fTitle = '' then fTitle := fURL;

end;

// ----------------------------------------------------------------------------- 

// ----------------------------------------------------------------------------- 

end.