画像のURL(MelanderBlogのコンポーネント)に関して (ID:41504)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

ブラウザから画像をDragした時に、どんなデータが渡されるのかを調べてListViewに列挙してやれば、求める画像データが含まれるか確認できます。
リンク付きの画像をそのままDragした場合は画像データが含まれないことが分かります。
なので、画像データが含まれるようにDragするためには、その画像を選択状態(画像に網がかかった状態)にしてからDragする必要があります。
そうすれば、画像の情報(HTMLテキスト)が含まれるので、画像のURLを取得できます。

unit U_TestDropComboTarget;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, ExtCtrls, DragDrop, DropTarget, DragDropGraphics, //JPEG,
  DropComboTarget, StdCtrls, ActiveX, ComCtrls, OleCtrls, SHDocVw_TLB,
  UIWebBrowser, OleErrors;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Image1: TImage;
    DropComboTarget1: TDropComboTarget;
    Button1: TButton;
    Memo1: TMemo;
    MemoHTML: TMemo;
    ListView1: TListView;
    UIWebBrowser1: TUIWebBrowser;
    Edit1: TEdit;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure DropComboTarget1Drop(Sender: TObject;
      ShiftState: TShiftState; APoint: TPoint; var Effect: Integer);
  private
    { Private 宣言 }
    FSize: Integer;
    function FormatTypeToString(cf: Word): string;
    procedure HandleHTML(dataObj: IDataObject;  fetc: TFormatEtc);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  本フォームの上にTPanelを配置，そのTPanelにTImaeを配置してある
//
//  TargetをTPanelにする
//  対象のフォーマット指定．テキスト等もテスト可能なように設定
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  DropComboTarget1.Target := Panel1;  //ScrollBox1;

DropComboTarget1.Formats := [];
  DropComboTarget1.Formats := DropComboTarget1.Formats + [mfText];
  DropComboTarget1.Formats := DropComboTarget1.Formats + [mfFile];
  DropComboTarget1.Formats := DropComboTarget1.Formats + [mfURL];
  DropComboTarget1.Formats := DropComboTarget1.Formats + [mfBitmap];
  DropComboTarget1.Formats := DropComboTarget1.Formats + [mfMetaFile];
  DropComboTarget1.Formats := DropComboTarget1.Formats + [mfData];

Image1.Transparent := True;
end;

//=============================================================================
//  TDropComboTargetのOnDropイベント
//=============================================================================

procedure TForm1.DropComboTarget1Drop(Sender: TObject;
  ShiftState: TShiftState; APoint: TPoint; var Effect: Integer);
var
  DataObj: IDataObject;
  stgm: TSTGMEDIUM;
  fetc: TFormatEtc;
  ef: IEnumFORMATETC;
  s, sD: string;
  p: Pointer;
  O: TClass;
  sz: array[0..255] of char;
begin
  MemoHTML.Clear;
  Memo1.Clear;
  ListView1.Items.Clear;
  Edit1.Text := '';
  Image1.Picture.Assign(nil);
  UIWebBrowser1.Navigate('about:blank');
  O := ExceptionClass;
  ExceptionClass := EAbort;
  DataObj := DropComboTarget1.DataObject;
  // IEnumFORMATETC interfaceを取得
  DataObj.EnumFormatEtc(DATADIR_GET, ef);
  // FormatEtc列挙
  while(ef.Next(1, fetc, nil) <> S_FALSE) do begin
    FSize := 0;
    // FormatEtc記述名を取得
    GetClipboardFormatName(fetc.cfFormat, @sz, Sizeof(sz)-1);
    if(sz = 'HTML Format') then begin
      HandleHTML(DataObj, fetc);
    end;
    with ListView1.Items.Add do begin
      Caption := FormatTypeToString(fetc.cfFormat);
      SubItems.Add(IntToStr(FSize));
    end;
  end;
  if DropComboTarget1.Bitmap.Handle <> 0 then begin
    Image1.Picture.Assign(DropComboTarget1.Bitmap);
  end else
  if DropComboTarget1.MetaFile.Handle <> 0 then begin
    Image1.Picture.Assign(DropComboTarget1.MetaFile);
  end;
  ExceptionClass := O;
  Memo1.Text := DropComboTarget1.Text;
  Caption := DropComboTarget1.URL;
end;

//=============================================================================
//  ついでにクリップボードからの[貼り付け]テスト
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  DropComboTarget1.PasteFromClipboard;
end;

//=============================================================================
//リンク付き画像の場合、それを選択して網がかかった状態にしてからDragする必要あり
//=============================================================================
function TForm1.FormatTypeToString(cf: Word): string;
var
   sz: array[0..255] of char;
begin
  case (cf) of
    CF_TEXT         : result := 'CF_TEXT';
    CF_BITMAP       : result := 'CF_BITMAP';
    CF_METAFILEPICT : result := 'CF_METAFILEPICT';
    CF_SYLK         : result := 'CF_SYLK';
    CF_DIF          : result := 'CF_DIF';
    CF_TIFF         : result := 'CF_TIFF';
    CF_OEMTEXT      : result := 'CF_OEMTEXT';
    CF_DIB          : result := 'CF_DIB';
    CF_PALETTE      : result := 'CF_PALETTE';
    CF_PENDATA      : result := 'CF_PENDATA';
    CF_RIFF         : result := 'CF_RIFF';
    CF_WAVE         : result := 'CF_WAVE';
    CF_UNICODETEXT  : result := 'CF_UNICODETEXT';
    CF_ENHMETAFILE  : result := 'CF_ENHMETAFILE';
    CF_HDROP        : result := 'CF_HDROP';
    CF_LOCALE       : result := 'CF_LOCALE';
    CF_MAX          : result := 'CF_MAX';
  else
    begin
      GetClipboardFormatName(cf, @sz, Sizeof(sz)-1);
      result := '[' + IntToStr(cf) + '] ' + sz;
    end;
  end;
end;

procedure TForm1.HandleHTML(dataObj: IDataObject; fetc: TFormatEtc);
const
  OFS_HTM = 'StartHTML:';
  TGT_URL = 'SourceURL:';
var
  BaseTAG, BaseURL: string;
  //---------------------------------------------
  function InsertBaseTAG(HTMLCode: PChar; out InsPtr: PChar): Integer;
  var
    p, pH: PChar;
  begin
    result := 0;
    InsPtr := nil;
    //HTML先頭までのオフセット
    p := StrPos(HTMLCode, OFS_HTM);
    if p <> nil then begin
      inc(p, Length(OFS_HTM));
      pH := p;
      while not(p^ in [#0,#13]) do inc(p);
      if p^ = #0 then exit;
      p^ := #0;
      result := StrToIntDef(pH, 0);
      p^ := #13;
      // BaseURLを抽出
      pH := StrPos(p+1, TGT_URL);
      if pH <> nil then begin
        inc(pH, Length(TGT_URL));
        p := HTMLCode + result;
        if p^ <> '<' then exit;
        while (p-1)^ <> '/' do dec(p);
        p^ := #0;
        BaseURL := Trim(pH);
        BaseTAG := '<BASE HREF="'+ Trim(pH) +'">'#13#10;
        p^ := '<';
      end;
    end;
    // BaseTAGの挿入位置を探す
    InsPtr := StrPos(p+1, '<HEAD>');      // <HEAD>の直後
    if InsPtr <> nil then begin
      inc(InsPtr, Length('<HEAD>'));
      if (InsPtr)^ <> #13 then BaseTAG := #13#10 + BaseTAG;
    end;
  end;
  // HTMLテキストをブラウザに読み込んで表示
  procedure WB_LoadHTML(WebBrowser: TUIWebBrowser; HTMLCode: PChar);
  var
    ms: TMemoryStream;
  begin
    WebBrowser.Navigate('about:blank');
    while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do begin
      Application.ProcessMessages;  Sleep(1);
    end;
    if Assigned(WebBrowser.Document) then begin
      with TStringList.Create do
      try
        ms := TMemoryStream.Create;
        try
          Text := HTMLCode;
          SaveToStream(ms);
          ms.Seek(0, 0);
          (WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));
        finally
          ms.Free;
        end;
      finally
        Free;
      end;
    end;
  end;
  //-------------------------------------------------------
var
  p: Pointer;
  stgm: TSTGMEDIUM;
  s, sD: string;
  pN, pS: PChar;
  ofs: Integer;
begin
  if(dataObj.QueryGetData(fetc) = NOERROR) then begin
    OleCheck(dataObj.GetData(fetc, stgm));
    p := GlobalLock(stgm.hGlobal);
    try
      FSize := GlobalSize(stgm.hGlobal);
      s  := Utf8ToAnsi(PChar(p));
      ofs := InsertBaseTAG(PChar(s), PChar(pN));
      if pN <> nil then begin
        pN^ := #0;
        sD := PChar(s) + BaseTAG;
        pN^ := '<';
        sD := sD + pN;
        MemoHTML.Text := sD;
      end else begin
        sD := s;
        MemoHTML.Text := s;
      end;
      WB_LoadHTML(UIWebBrowser1, PChar(sD) + ofs);
      pN := StrPos(pN, '');
      if pN = nil then exit;
      pN := StrPos(pN, 'src="');
      if pN <> nil then begin
      pS := pN + StrLen('src="');
      pN := pS;
       while pN^ <> '"' do inc(pN);
      pN^ := #0;
      if StrLComp(pS, 'http', 4) = 0 then
        Edit1.Text := pS
      else
        Edit1.Text := BaseURL + pS;
    end;
    finally
      GlobalFree(stgm.hGlobal);
      ReleaseStgMedium(stgm);
    end;
  end;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る