Mr.XRAYさんのサイト「Delphiサンプルプログラム集」
http://mrxray.on.coocan.jp/Delphi/plSamples/821_Application_DragDrop.htm
の真ん中よりちょっと下に
リスト4
ブラウザからドロップした画像のURLは，URLプロパティで取得可能
ShowMessage(DropComboTarget1.URL);
というのがあります。
例えばJpeg画像をドロップした場合、DropComboTarget1.URLの内容が
「〜.jpg」という場合と、画像をリンクとして使用している場合は
そのリンク先のURLの場合があります。
後者の場合でも、ブラウザ上で右クリックすると「名前を付けて画像を保存」
というメニューが出てJpegファイルとして保存できますので、なんとかして
画像のURLを取得できそうな気がするのですが、何か方法があるのでしょうか？
（ここに質問するのはどうかなと思いましたが、結構いいコンポ集なので、
紹介も兼ねて＾＾；）
こんにちは．Mr.XRAYです．
私の名前が見えたので....
>画像のURLを取得できそうな気がするのですが、何か方法があるのでしょうか？
これは，ドラッグ，ドロップした時にということでしょうか?
もし，そうであれば，
DropComboTarget1.Text
で取得できるようですが... ハズしたかな?
もっともリダイレクトはしませんが．
ご回答ありがとうございます。
やってみましたが、うまくいきませんでした。
同じページの上部に、「山 Mr.XRAY」という画像がありますが、これをD&Dすると、
DropComboTarget1.Text も、DropComboTarget1.URL も、
http://mrxray.on.coocan.jp/Delphi/Images/Little_MrXRAY.gif
となって、これはファイル名が取得できます。
が、その左の「HOME」という画像では、共に
http://mrxray.on.coocan.jp/index.htm
となります・・・。これも同様に、
http://mrxray.on.coocan.jp/Delphi/Images/Hoome.gif
のような感じの文字列が取得できればいいんですが・・・。
なるほど．
どちらも同じ値で，リンク先がある時は，そのURL.ない時は，画像のパス名なんですね．
う〜む．調べないと分かりせん．
IDropTargetインターフェイスでは取得できないようですね．
仕様ということです．多分．残念ですが．
で，方法は他の方にバトンタッチします．
調べていただきありがとうございます。
そうですか・・・残念です＞＜
あまりにも簡単なレスなので，ちょっと説明を．
IDropTargetインターフェイスは受け取る側ですが，
受け取ることができるデータは，
ドラッグされる側，今回はブラウザ(IEやFireFox)ですが，こちらが実装している
IDropSourceによります．つまり，ブラウザ側がどんなデータを渡しているかによります．
つまり，URLやTextプロパティの値は，ブラウザとそのバージョンによって異なる可能性があります．
ブラウザから画像を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, '<!--StartFragment-->');
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.
