<   2015年 04月 ( 6 )   > この月の画像一覧
[Delphi] WM_DROPFILESメッセージを利用してドラッグ&ドロップの実現を試みる ⇒ 失敗
こんばんワイン。どーもボキです。

[Delphi] TShellListViewからエクスプローラへドラッグ&ドロップするでは、OLEを利用した(サンプルを転用した)。

EXEウィンドウへのドロップを受け付けるには、WM_DROPFILESメッセージを処理すればよいので、
Explorerへも同様にWM_DROPFILESメッセージでドロップするファイルパスを渡してやればよいのでは?と作ってみた。結果はNG

Explorerにドロップしてもウンともスンとも言わない。以下の参考サイトの3にもか書かれていたが、WM_DROPFILESメッセージの処理では上手く行かないと思われる。
メモ帳へのドロップは、タイトルバー位置(TextEditorWindow)ならばドロップしたファイルが開かれるが、それ以外の領域では反応しない。

参考サイト
 1.Delphi6 ローテクTipsウィンドウハンドルから実行ファイル名を取得
 2.Torry's Delphi Pages > ...send data to another program by auto-drag&drop?
 3.Visual Basic 掲示板 > WM_DROPFILEメッセージの引数の構造体は?
unit Unit1;

interface

uses
ShellAPI,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ShellCtrls, ExtCtrls, StdCtrls, ShlObj, ActiveX, ComObj;

type
TForm1 = class(TForm)
GroupBox1: TGroupBox;
ShellTreeView1: TShellTreeView;
Splitter1: TSplitter;
GroupBox2: TGroupBox;
ShellListView: TShellListView;
procedure ShellListViewEndDrag(Sender, Target: TObject; X, Y: Integer);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;

var
Form1: TForm1;

implementation


{$R *.dfm}

{ TForm1 }


function MakeDrop(const FileNames: array of string): THandle;
// Creates a hDrop Object
// erzeugt ein hDrop Object
var
i, size: Integer;
dt: PDragInfoA;
p: PChar;
begin
// Calculate memory size needed
// berechne notwendig Speichergrose
size := SizeOf(TDragInfoA) +1;
for i := 0 to High(FileNames) do
Inc(size, Length(FileNames[i]) +1);
// allocate the memory
// alloziere den speicher
Result := GlobalAlloc(GHND or GMEM_SHARE, size);

if Result <> 0 then begin
dt := GlobalLock(Result);
if dt <> nil then
try
// fill up with dt
// fulle daten
dt.uSize := SizeOf(TDragInfoA);
p := PChar(@dt.grfKeyState) + 4;
dt.lpFileList := p;
// filenames at the at of the header (separated with #0)
// am ende des headers nun die filenamen getrennt mit #0
for i := 0 to High(FileNames) do begin
size := Length(FileNames[i]);
Move(Pointer(FileNames[i])^, p^, size);
Inc(p, size + 1);
end;
finally
GlobalUnlock(Result);
end
else begin
GlobalFree(Result);
Result := 0;
end;
end;
end;


// ドラッグ終了時にPostMessageを発行
procedure TForm1.ShellListViewEndDrag(Sender, Target: TObject; X, Y: Integer);
var
lpt_Pos : TPoint;
lh_Handle : HWND;
_SLV : TShellListView;
sarr : Array of String;
i,idx : integer;
hdrp : hDrop;
begin
//マウスカーソルの位置を取得(スクリーン座標)
GetCursorPos(lpt_Pos);
//マウスカーソル下のウィンドウを取得し
lh_Handle := WindowFromPoint(lpt_Pos);
if lh_Handle = 0 then exit;

// 選択パスの取得
_SLV := TShellListView(Sender);
SetLength(sarr, _SLV.SelCount);
idx := 0;
for i := 0 to _SLV.Items.Count -1 do begin
if not _SLV.Items[i].Selected then continue;

sarr[idx] := _SLV.Folders[i].PathName;
Inc(idx);
end;

// WM_DROPFILESを発行
hdrp := MakeDrop(sarr);
if hdrp <> 0 then PostMessage(lh_Handle, WM_DROPFILES, hdrp, 0);
GlobalFree(hdrp);
end;


end.


[PR]
by yozda | 2015-04-30 22:20 | プログラミング | Trackback | Comments(0)
[Delphi] TFileListBoxからエクスプローラへドラッグ&ドロップする。
こんばんワイン。どーもボキです。

前回参考にしたDelFusa Floorのアーカイブ(Delphi Users’ Forum)を作ってみた。元ネタはMouseMoveイベントとなっていたが、DragOverイベントに置き換えた。
a0021757_0433863.gif



こちらも、ドラッグ&ドロップ処理が多重に動いているような動作をする(ドロップ処理がすぐに終了しない)が、
読み込み違反エラーは起きない。TShellListView側にも問題があるのかも知れない。
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, ActiveX, ShlObj, ComObj, ExtCtrls;

type
TForm1 = class(TForm, IDropSource)
GroupBox1: TGroupBox;
Splitter1: TSplitter;
GroupBox2: TGroupBox;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
procedure FileListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FileListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure FileListBox1EndDrag(Sender, Target: TObject; X, Y: Integer);
private
{ Private 宣言 }
FDragStartPos: TPoint;

//IDropSource のメソッド 以下2つ
function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
function GiveFeedback(dwEffect: Longint): HResult; stdcall;
public
{ Public 宣言 }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}


//ファイル名からIDataObjectインターフェイスを取得
function GetFileListDataObject(const Directory: String; Files : TStringList) : IDataObject;
type
PArrayOfPItemIDList = ^TArrayOfPItemIDList;
TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
Malloc : IMalloc;
fDesktop,fTargetFolder : IShellFolder;
i : Integer;
Dirpidl : PItemIDList;
p : PArrayOfPItemIDList;
chEaten,dwAttributes: ULONG;
begin
Result := nil;
if Files.Count = 0 then exit;

OleCheck(SHGetMalloc(Malloc));
OleCheck(SHGetDesktopFolder(fDesktop));
OleCheck(fDesktop.ParseDisplayName(0, nil, PWideChar(WideString(Directory)), chEaten, Dirpidl, dwAttributes));
try
OleCheck(fDesktop.BindToObject(Dirpidl, nil, IShellFolder, fTargetFolder));
p := AllocMem(SizeOf(PItemIDList) * Files.Count);
try
for i := 0 to Files.Count -1 do begin
OleCheck(fTargetFolder.ParseDisplayName(0, nil, PWideChar(WideString(Files[i])), chEaten, p[i], dwAttributes));
end;
OleCheck(fTargetFolder.GetUIObjectOf(0, Files.Count, p[0], IDataObject, nil, Pointer(Result)));
finally
for i := 0 to Files.Count -1 do begin
if p[i] <> nil then Malloc.Free(p[i]);
end;
FreeMem(p);
end;
finally
Malloc.Free(Dirpidl);
end;
end;


//現在行われようとしている操作に応じてカーソルを設定できる
function TForm1.GiveFeedback(dwEffect : Longint): HResult;
begin
//デフォルトのカーソルを使う
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;


//ユーザーがドラッグ操作の中止を求めた場合 fEscapePressed や
//マウスの状態に応じてドラッグの継続の可否をOLEに通知
function TForm1.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Integer): HResult;
begin
//ESCが押されたか、両方のボタンが押されている場合は中止する
if fEscapePressed or ((MK_LBUTTON or MK_RBUTTON) = (grfKeyState and (MK_LBUTTON or MK_RBUTTON))) then
Result := DRAGDROP_S_CANCEL

//マウスの左ボタンが離された場合はドロップ処理へ
else if (grfKeyState and MK_LBUTTON) = 0 then begin
Result := DRAGDROP_S_DROP;

//それ以外はD&D継続
end else begin
Result := S_OK;
end;
end;


// マウスダウンによる初期化
procedure TForm1.FileListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then exit;
if TFileListBox(Sender).SelCount = 0 then exit;

FDragStartPos := Point(X, Y);
end;


// ファイル/フォルダのドラッグ
procedure TForm1.FileListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var
_FLB : TFileListBox;
slst : TStringList;
i,dwEffect : Integer;
s,dpth : String;
DataObject : IDataObject;
begin
//if State <> dsDragLeave then exit; ※コントロールから離れた時のみとすると、メモリアクセスエラーが置きやすい。
if ((Abs(X - FDragStartPos.X) < Mouse.DragThreshold) and (Abs(Y - FDragStartPos.Y) < Mouse.DragThreshold)) then exit;

_FLB := TFileListBox(Sender);
dpth := _FLB.Directory;
try
slst := TStringList.Create;
slst.Capacity := _FLB.SelCount;
for i := 0 to _FLB.Items.Count -1 do begin
if _FLB.Selected[i] then begin
s := _FLB.Items[i];
slst.Add(s);
end;
end;
//ファイル名からIDataObjectを取得
DataObject := GetFileListDataObject(dpth,slst);
finally
slst.Free;
end;

//OLEドラッグ&ドロップ開始
dwEffect := DROPEFFECT_NONE;
DoDragDrop(DataObject, Self, DROPEFFECT_COPY, dwEffect);
end;


// 表示更新
procedure TForm1.FileListBox1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
TFileListBox(Sender).Refresh;
end;


initialization
OleInitialize(nil);


finalization
OleUninitialize;


end.


[PR]
by yozda | 2015-04-29 00:42 | プログラミング | Trackback | Comments(0)
[Delphi] TShellListViewからエクスプローラへドラッグ&ドロップする
こんにチワワ。どーもボキです。

TShellListViewに表示したフォルダ・ファイルを、デスクトップ等にコピーできるようにするサンプル。
Asuyu HomepageDelFusa Floorのアーカイブ(Delphi Users’ Forum)を参考にした。
a0021757_0372278.gif



原因不明のトラブルが2つ。
一つ目は、1つのファイル・フォルダのドラッグではマウスアイコンが表示されない。
2つ以上を選択しドラッグした後は、1つのみの選択時もアイコンが表示される。

二つ目は、ドロップ終了後にEXEウィンドウにカーソルを戻すと高確率で起きる読み込み違反エラー。
ドラッグ&ドロップ処理が多重に動くためと思われるが、回避方法が分からない。

----------
15.05.09
DragOverイベントで、コントロールから外れたときにDragDropを実行させていたが、
それをやめることで読み込み違反エラーは回避(大幅頻度低下)できそう。以下ソースは修正済み。
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ShellCtrls, ExtCtrls, StdCtrls, ShlObj, ActiveX, ComObj;

type
TForm1 = class(TForm, IDropSource)
GroupBox1: TGroupBox;
ShellTreeView1: TShellTreeView;
Splitter1: TSplitter;
GroupBox2: TGroupBox;
ShellListView: TShellListView;
procedure ShellListViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ShellListViewDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure ShellListViewEndDrag(Sender, Target: TObject; X, Y: Integer);
private
{ Private 宣言 }
FDragStartPos : TPoint;

//IDropSource のメソッド 以下2つ
function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
function GiveFeedback(dwEffect: Longint): HResult; stdcall;
public
{ Public 宣言 }
end;

var
Form1: TForm1;

implementation


{$R *.dfm}

{ TForm1 }


//ファイル名からIDataObjectインターフェイスを取得
function GetFileListDataObject(const Directory: String; Files : TStringList) : IDataObject;
type
PArrayOfPItemIDList = ^TArrayOfPItemIDList;
TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
Malloc : IMalloc;
fDesktop,fTargetFolder : IShellFolder;
i : Integer;
Dirpidl : PItemIDList;
p : PArrayOfPItemIDList;
chEaten,dwAttributes: ULONG;
begin
Result := nil;
if Files.Count = 0 then exit;

OleCheck(SHGetMalloc(Malloc));
OleCheck(SHGetDesktopFolder(fDesktop));
OleCheck(fDesktop.ParseDisplayName(0, nil, PWideChar(WideString(Directory)), chEaten, Dirpidl, dwAttributes));
try
OleCheck(fDesktop.BindToObject(Dirpidl, nil, IShellFolder, fTargetFolder));
p := AllocMem(SizeOf(PItemIDList) * Files.Count);
try
for i := 0 to Files.Count -1 do begin
OleCheck(fTargetFolder.ParseDisplayName(0, nil, PWideChar(WideString(Files[i])), chEaten, p[i], dwAttributes));
end;
OleCheck(fTargetFolder.GetUIObjectOf(0, Files.Count, p[0], IDataObject, nil, Pointer(Result)));
finally
for i := 0 to Files.Count -1 do begin
if p[i] <> nil then Malloc.Free(p[i]);
end;
FreeMem(p);
end;
finally
Malloc.Free(Dirpidl);
end;
end;


//現在行われようとしている操作に応じてカーソルを設定できる
function TForm1.GiveFeedback(dwEffect : Longint): HResult;
begin
//デフォルトのカーソルを使う
Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;


//ユーザーがドラッグ操作の中止を求めた場合 fEscapePressed や
//マウスの状態に応じてドラッグの継続の可否をOLEに通知
function TForm1.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Integer): HResult;
begin
//ESCが押されたか、両方のボタンが押されている場合は中止する
if fEscapePressed or ((MK_LBUTTON or MK_RBUTTON) = (grfKeyState and (MK_LBUTTON or MK_RBUTTON))) then
Result := DRAGDROP_S_CANCEL

//マウスの左ボタンが離された場合はドロップ処理へ
else if (grfKeyState and MK_LBUTTON) = 0 then begin
Result := DRAGDROP_S_DROP;

//それ以外はD&D継続
end else begin
Result := S_OK;
end;
end;


// マウスダウンによる初期化
procedure TForm1.ShellListViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then exit;
if TShellListView(Sender).SelCount = 0 then exit;

FDragStartPos := Point(X, Y);
end;


// ファイル/フォルダのドラッグ
procedure TForm1.ShellListViewDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var
_STV : TCustomShellTreeView;
_SLV : TShellListView;
slst : TStringList;
i,dwEffect : Integer;
s,dpth : String;
DataObject : IDataObject;
begin
//if State <> dsDragLeave then exit; ※コントロールから離れた時のみとすると、メモリアクセスエラーが置きやすい。
if ((Abs(X - FDragStartPos.X) < Mouse.DragThreshold) and (Abs(Y - FDragStartPos.Y) < Mouse.DragThreshold)) then exit;

_SLV := TShellListView(Sender);
_STV := _SLV.ShellTreeView;
dpth := _STV.Path;
try
slst := TStringList.Create;
slst.Capacity := _SLV.SelCount;
for i := 0 to _SLV.Items.Count -1 do begin
if _SLV.Items[i].Selected then begin
s := _SLV.Folders[i].PathName;
slst.Add(Copy(s, Pos(dpth,s)+Length(dpth)+1,Length(s)))
end;
end;
//ファイル名からIDataObjectを取得
DataObject := GetFileListDataObject(dpth,slst);
finally
slst.Free;
end;

//OLEドラッグ&ドロップ開始
dwEffect := DROPEFFECT_NONE;
DoDragDrop(DataObject, Self, DROPEFFECT_COPY, dwEffect);
end;


// 表示更新
procedure TForm1.ShellListViewEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
TShellListView(Sender).Refresh
end;


initialization
OleInitialize(nil);


finalization
OleUninitialize;


end.



[PR]
by yozda | 2015-04-28 16:20 | プログラミング | Trackback(3) | Comments(0)
[Excel] メモ帳を使ってマクロをデバッグする。
こんにチワワ。どーもボキです。
12連休です。

Excelマクロのデバッグをちょっと楽にするデバッグ用関数WriteNote
引数で渡した文字列をメモ帳に出力するよ。
Dim hNotePad, hNotepadEditClass As Long

' Windows API
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As Long

Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, _
ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, _
ByVal lpszWindow As String _
) As Long

Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As String _
) As Long

Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long

Declare Function SetWindowPos Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long _
) As Long

Declare Function SetWindowText Lib "user32.dll" Alias "SetWindowTextA" ( _
ByVal hWnd As Long, _
ByVal lpString As String _
) As Long

' メモ帳に文字列を出力
Public Sub WriteNote(s As String)
Const EM_REPLACESEL As Long = &HC2
Const EM_SETMODIFY As Long = &HB9
Const WM_NULL As Long = &H0
Const ES_AUTOVSCROLL As Long = &H40
Const HWND_TOPMOST As Long = -1
Const SWP_NOSIZE As Long = 1
Const SWP_NOMOVE As Long = 2
Const SWP_NOACTIVATE As Long = &H10

hNotePad = FindWindow("Notepad", vbNullString)
If hNotePad = 0 Then
' メモ帳がない⇒起動
Shell "Notepad.exe", vbNormalFocus
Do While hNotePad = 0
hNotePad = FindWindow("Notepad", vbNullString)
DoEvents
Loop

Call SendMessage(hNotePad, WM_NULL Or ES_AUTOVSCROLL, 0, 0) ' 自動スクロール
Call SetWindowText(hNotePad, ThisWorkbook.Name) ' メモ帳キャプション変更
Call SetWindowPos(hNotePad, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE) ' 最前面

hNotepadEditClass = FindWindowEx(hNotePad, 0, "Edit", vbNullString)
End If

Call SendMessage(hNotepadEditClass, EM_REPLACESEL, 0, s & vbCrLf) ' 文字列を送信
Call SendMessage(hNotepadEditClass, EM_SETMODIFY, 0, 0) ' 変更フラグOFF
End Sub


'Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Const WM_QUIT = &H12
' Call PostMessage(hNotePad, WM_QUIT, 0, 0)
'End Sub

' 終了時にメモ帳を閉じる
Private Sub Auto_Close()
Const WM_QUIT = &H12
Call PostMessage(hNotePad, WM_QUIT, 0, 0)
End Sub




[PR]
by yozda | 2015-04-25 20:03 | プログラミング | Trackback(1) | Comments(0)
[Excel] OutputDebugStringを使ってマクロをデバッグする。
こんばんワイン。どーもボキです。

APIのOutputDebugStringをラッパーした関数dprintf
出力メッセージを拾うには、DebugViewが必要。
Declare Sub OutputDebugString Lib "kernel32.dll" Alias "OutputDebugStringA" (ByVal lpOutputString As String)

Sub dprintf(v)
Dim i, s, ityp

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = ""
For i = 0 To UBound(v)
s = s & "dprintf(" & CInt(i) & ") =" & v(i) & vbCrLf
Next
End If
OutputDebugString (s)
End Sub
[Excel] メモ帳を使ってマクロをデバッグする。

[PR]
by yozda | 2015-04-25 19:57 | プログラミング | Trackback | Comments(0)
春の味覚
もっとセリを食べたかったんだが、毒ゼリというものがあるらしいのでやめた。
筍は実家の母が送ってくれたもの。家族全員でおいしい*2と食べたよ。
a0021757_16294313.jpg
a0021757_2017146.jpg

[PR]
by yozda | 2015-04-19 16:28 | 暮らし | Trackback | Comments(0)