タグ:Delphi ( 39 ) タグの人気記事
[Delphi] TShellTreeViewやTShellListView間でドラッグ&ドロップする 【EListError回避版】
こんにチワワ。どーもボキです。

前回の紹介バージョンでは、何も入っていないフォルダに対してドロップを行うと、TListErrorが発生する。(下図)
ちなみに、エラーメッセージウィンドウを閉じれば押せば正常に処理される。

おそらくTShellListViewかその親となるコンポーネントにバグがあると思われるが、
ShellCtrls.pasのソースがインストールされてなく修正できない(あってもやらない)ので、別の回避方法を考えた。
a0021757_1733233.gif


以下のように、TShellListViewが何も表示していない場合、
DragDropイベント時にダミーファイルを作成し表示更新させ、EndDragイベントで、そのダミーファイルを消す。

こうすればエラーを回避できる。
// ドラッグ中にダミーファイル作成
procedure TForm1.ShellListView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
_SLV : TCustomShellListView;
_STV : TCustomShellTreeView;
begin
if Sender is TShellListView then begin
_SLV := TCustomShellListView(Sender);
_STV := _SLV.ShellTreeView;
end else if Sender is TShellTreeView then begin
_STV := TCustomShellTreeView(Sender);
_SLV := _STV.ShellListView;
end else exit;
if _SLV.Items.Count > 0 then exit;

//※EListError回避のため、ダミーファイルを作成し表示更新
FileClose(FileCreate(_STV.Path+'\AvoidEListError'));
_SLV.Refresh;
end;

// ドラッグ終了時にコピー処理
procedure TForm1.ShellListView1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
//~ 省略 ~

DeleteFile(_STV[1].Path +'\AvoidEListError'); // ダミーファイルを削除
_SLV.Refresh;
end;

[Delphi] TShellTreeViewやTShellListView間でドラッグ&ドロップする
[PR]
by yozda | 2015-05-17 17:02 | プログラミング | Trackback | Comments(0)
[Delphi] TShellTreeViewやTShellListViewのシェルメニューを表示させない
こんばんワイン。どーもボキです。

AutoContextMenus := False; とするだけだったわ。


TShellTreeViewやTShellListViewを右クリックした際に表示されるシェルメニューをOFFにする方法。
TApplicationEventsのMessageで、右ボタンのダウン・アップを無視させればよい。

a0021757_18501935.gif
unit Unit1;

interface

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

type
TForm1 = class(TForm)
GroupBox1: TGroupBox;
ShellTreeView1: TShellTreeView;
Splitter1: TSplitter;
GroupBox2: TGroupBox;
ShellListView: TShellListView;
ApplicationEvents1: TApplicationEvents;
procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;

var
Form1: TForm1;

implementation


{$R *.dfm}

{ TForm1 }



procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
begin
//※シェルメニューをOFFとするため、左ダブルクリック、右クリックメニューを無効
case Msg.message of
WM_LBUTTONDBLCLK,WM_RBUTTONDOWN,WM_RBUTTONUP : Handled := True;
end;
end;

end.


[PR]
by yozda | 2015-05-02 18:50 | プログラミング | Trackback | Comments(0)
[Delphi] TShellTreeViewやTShellListView間でドラッグ&ドロップする
こんにチワワ。どーもボキです。

TShellTreeViewやTShellListView間でドラッグ&ドロップするサンプル。
サンプルプログラム

[Delphi] TShellListViewからエクスプローラへドラッグ&ドロップするとは、両立出来ない
a0021757_16592497.gif
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
GroupBox1: TGroupBox;
ShellTreeView1: TShellTreeView;
Splitter1: TSplitter;
GroupBox2: TGroupBox;
ShellListView1: TShellListView;
Splitter2: TSplitter;
Panel2: TPanel;
Splitter3: TSplitter;
GroupBox3: TGroupBox;
ShellTreeView2: TShellTreeView;
GroupBox4: TGroupBox;
ShellListView2: TShellListView;
Timer1: TTimer;
procedure ShellListView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure ShellListView1EndDrag(Sender, Target: TObject; X, Y: Integer);
procedure Timer1Timer(Sender: TObject);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

var
node0 : TTreeNode = nil;


const
// OperateShell用
osMove = FO_MOVE;
osCopy = FO_COPY;
osDelete = FO_DELETE;
osRename = FO_RENAME;
osMove_Undo = FOF_ALLOWUNDO +FO_MOVE; // ゴミ箱に残す
osCopy_Undo = FOF_ALLOWUNDO +FO_COPY;
osDelete_Undo = FOF_ALLOWUNDO +FO_DELETE;
osRename_Undo = FOF_ALLOWUNDO +FO_RENAME;

// フォルダ一括操作
function OperateShell(OperateMode : Integer; Path_From, Path_To : String): Boolean;
var
rshf : TSHFILEOPSTRUCT;
cmd,mode : Integer;
begin
Result := False;
if Path_From = Path_To then exit;
if not( FileExists(Path_From) or DirectoryExists(Path_From) ) then exit;
if DirectoryExists(Path_From) and FileExists(Path_To) then exit;

cmd := OperateMode mod $10;
mode := OperateMode div $10 * $10; // FOF_ALLOWUNDOのON/OFF
if not (cmd in [FO_MOVE..FO_RENAME]) then exit;

if cmd in [FO_MOVE, FO_COPY] then begin
// 処理先チェック
if RightStr(Path_To, 1) = '\' then begin // \終わりの場合は、フォルダパスとして処理
if not DirectoryExists(Path_To) then
if not ForceDirectories(Path_To) then exit;
end;

if ExtractFilePath(Path_From) = IncludeTrailingPathDelimiter(Path_To) then exit;
end;

Path_From := ExcludeTrailingPathDelimiter(Path_From);
Path_To := ExcludeTrailingPathDelimiter(Path_To);

with rshf do begin
wnd := Application.Handle;
wFunc := cmd;
pFrom := PChar(Path_From +#0);
pTo := PChar(Path_To +#0);
fFlags := FOF_NOCONFIRMATION or mode;
end;

//FOF_NOCONFIRMATIONを指定しない場合ダイアログが表示されるが、それがキャンセルされたかはわからない
Result := SHFileOperation(rshf) = 0; // 成功=0
end;



// ドラッグ中
procedure TForm1.ShellListView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var
node : TTreeNode;
begin
if Sender is TShellListView then exit;

node := TShellTreeView(Sender).GetNodeAt(X, Y);
if node = nil then exit;

if node0 = nil then begin
node0 := node;
Timer1.Enabled := True;
end else if node0 <> node then begin
Timer1.Enabled := False;
node0 := nil;
end;
end;



// ドラッグ終了時にコピー処理
procedure TForm1.ShellListView1EndDrag(Sender, Target: TObject; X, Y: Integer);
label
_END_;
var
_STV : Array[0..1] of TCustomShellTreeView;
_SLV : Array[0..1] of TCustomShellListView;
i,r,cnt : Integer;
s1 : String;
s0 : TStringList;
item : TListItem;
node : TTreeNode;
//----------------------------------------------------------------------------
function _checkComp(Sender : TObject; Index : Integer) : Integer;
begin
Result := -1;
if Sender is TShellListView then begin
Result := 0;
_SLV[Index] := TCustomShellListView(Sender);
_STV[Index] := _SLV[Index].ShellTreeView;
end else if Sender is TShellTreeView then begin
Result := 1;
_STV[Index] := TCustomShellTreeView(Sender);
_SLV[Index] := _STV[Index].ShellListView;
end;
end;
//----------------------------------------------------------------------------
begin
s0 := TStringList.Create;

// ドロップ先
node := nil;
case _checkComp(Target,1) of
0 : begin
// TShellListView
s1 := _STV[1].Path;
if Sender = Target then begin
for i := 0 to _SLV[1].Items.Count -1 do
if _SLV[1].Items[i].Selected then
s0.Add(_SLV[1].Folders[i].PathName);
end;

for i := 0 to _SLV[1].Items.Count -1 do
_SLV[1].Items[i].Selected := False; // 前回の選択をリセット

item := _SLV[1].GetItemAt(X, Y);
if item <> nil then begin
item.Selected := True;
if _SLV[1].SelectedFolder <> nil then begin
s1 := _SLV[1].SelectedFolder.PathName;
if FileExists(s1) then s1 := ExcludeTrailingPathDelimiter(ExtractFilePath(s1)); // 送信先を選択パスで更新

for i := 0 to _STV[1].Items.Count -1 do begin
if _STV[1].Folders[i].PathName <> s1 then continue;

node := _STV[1].Items[i];
break;
end;
end;
end;
end;

1 : begin
// TShellTreeView
node := _STV[1].GetNodeAt(X, Y);
if node = nil then s1 := _STV[1].Path
else s1 := TShellFolder(node.Data).PathName;
end;

else goto _END_;
end;

// ドロップ元
r := _checkComp(Sender,0);
case r of
0 : begin
if s0.Count = 0 then begin
for i := 0 to _SLV[0].Items.Count -1 do
if _SLV[0].Items[i].Selected then
s0.Add(_SLV[0].Folders[i].PathName);
end;
end;
1 : begin
for i := 0 to _STV[0].Items.Count -1 do
if _STV[0].Items[i].Selected then
s0.Add(_STV[0].Folders[i].PathName);
end;

else goto _END_;
end;

// コピー実行
cnt := 0;
for i := 0 to s0.Count -1 do
cnt := cnt +Ord(OperateShell(osCOPY, s0[i], s1));
if cnt = 0 then goto _END_;

// 表示更新
for i := 0 to 1 do _SLV[i].Refresh;
if node <> nil then node.Selected := True;

_END_:
s0.Free;
end;



procedure TForm1.Timer1Timer(Sender: TObject);
begin
if node0 = nil then exit;

node0.Expanded := True;
node0 := nil;
end;

end.
[Delphi] TShellListViewからエクスプローラへドラッグ&ドロップする

[PR]
by yozda | 2015-05-02 16:58 | プログラミング | Trackback(1) | Comments(0)
[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)
符号なし32ビット整数で4294967295(2^32-1)から、さらに+1するとどーなる?
こんばんワイン。どーもボキです。

符号なし32bit整数、Cならunsigned long、DelphiならCardinal。
この符号なし整数は、0 ~ (2^32)-1、つまり0 ~ 4294967295 まで格納できる。

4294967295 のとき、さらに+1するとどーなるか?


答え、0 になる。
4294967295(10)= FFFFFFFF(Hex)
 ↓
 ↓+1
 ↓
4294967296(10)=100000000(Hex)
したから8桁(4バイト=32ビット)使われるので、0になる。

なら、4294967295 よりも大きい値をカウントしたいときはどうしたらいいと思う?
↓↓

答え
[PR]
by yozda | 2011-06-30 00:08 | SE♂日誌 | Trackback | Comments(0)
[Delphi] TFrameを上手に使ってメンテナンス性を向上させる 番外編 ~TFrameをDLLで使うコツ~
どーもボキです。

フレームを利用したウィンドウを持ったDLLでは、フレームを作成する際にエラーが発生してしまう。
それは、TFrameは、EXEのハンドル(Application.Handle)を親にして自身を作成しているから。

EXEプロジェクトの場合は、自身のEXEハンドルを親にしてフレームが作成される。
しかし、DLLの場合、Application.Handle = 0 となっている。
つまり、親とするハンドルがないため、フレーム作成時にエラーが発生してしまう。

このエラーは、DLLのメインとなるフォームに一文を追加することで簡単に回避できる。
これより、DLLを呼び出したEXEのハンドルを親にしてフレームが正常に作成される。
Application.Handle := FindWindow(nil, PChar(Application.Title));

参考サイト

[PR]
by yozda | 2011-02-12 23:36 | プログラミング | Trackback | Comments(0)
[Delphi] TFrameを上手に使ってメンテナンス性を向上させる 5 ~メインフォームの作成~
どーもボキです。

今回は、前回までに作成した子フレームを呼び出すメインフォームを作成する。

実装するコードは以下。
Create時のフレーム作成&Init呼び出し、ボタンクリックイベントでのProc呼び出しの
どちらもFR_Commonで処理しているのがわかるだろうか?(下線部)

メインフォーム(uFM_Main.pas)のソースコード
unit uFM_Main;

interface

uses
uFR_Common,
uFR_Test1,
uFR_Test2,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, CheckLst;

type
TForm1 = class(TForm)
Pnl_Top: TPanel;
GBx_Left: TGroupBox;
Pnl_Main: TPanel;
LBx: TListBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure LBxClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
// ----------------------------------------------
procedure _initFrame(_FR : TFR_Common);
var
i : Integer;
begin
_FR.Parent := Pnl_Main; // フレームの親を指定
_FR.Align := alClient; //
i := LBx.Items.Add(_FR.Name); // フレーム名をリストに表示
LBx.Items.Objects[i] := _FR; // リストのObjectsにTFR_Commonのオブジェクトを格納
end;
// ----------------------------------------------
var
i : Integer;
begin
Pnl_Main.Align := alClient;
LBx.Align := alClient;

// FR_Testを作成
_initFrame(TFR_Test1.Create(Self));
_initFrame(TFR_Test2.Create(Self));

// Initを実行
for i := 0 to LBx.Count -1 do
TFR_Common(LBx.Items.Objects[i]).Init;

// FR_Test1を全面に表示
LBx.ItemIndex := 0;
TFR_Common(LBx.Items.Objects[0]).BringToFront;
end;



procedure TForm1.LBxClick(Sender: TObject);
var
i : Integer;
begin
i := LBx.ItemIndex;

// 該当するフレームを全面に表示
TFR_Common(LBx.Items.Objects[i]).BringToFront;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
i : Integer;
begin
i := LBx.ItemIndex;

// 該当するフレームのProcを実行
TFR_Common(LBx.Items.Objects[i]).Proc;
end;

end.
以下は、EXEの実行イメージ。
親フレームで処理させているにも関わらず、ちゃんと子フレームで実装した処理が実行されることが分かる。

これが、仮想メソッドをオーバーライドするってこと。
a0021757_22553231.gif
このようにTFrameを上手に利用すれば、
子フレームには、それぞれ独自処理をゴリゴリと実装でき、
それを呼び出すメインフォームでは、子フレームを意識することなく処理させることが出来る。

上手に活用して、無駄なくプログラムを管理してほしい。サンプルプログラム

[PR]
by yozda | 2011-02-12 23:16 | プログラミング | Trackback | Comments(0)
[Delphi] TFrameを上手に使ってメンテナンス性を向上させる 4 ~子フレームの作成2~
どーもボキです。

前回に引き続き、子フレームを作成する。
作成するフレームはこんな感じ。フレームにパネルを10枚貼り付けてある。
a0021757_22432049.gif


実装したコードは以下。
Initでは、パネルに表示されている文字を消去し、
Procでは、フレームにランダムに色を設定し、その色をベースにパネルの色をグラデーションさせている。

overrideを忘れずに。

この記事では、overrideのことよりも、むしろFindComponentでコンポーネントをfor文で管理したり、
指定した値分だけ色をズラす自作関数OffsetColorの方が、参考になるんじゃないかな?

子フレーム(uFR_Test2.pas)のソースコード
unit uFR_Test2;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, uFR_Common, ExtCtrls;

type
TFR_Test2 = class(TFR_Common)
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Panel5: TPanel;
Panel6: TPanel;
Panel7: TPanel;
Panel8: TPanel;
Panel9: TPanel;
Panel10: TPanel;
private
{ Private 宣言 }
public
{ Public 宣言 }
procedure Init; override;
procedure Proc; override;
end;

var
FR_Test2: TFR_Test2;

implementation

{$R *.dfm}

{ TFR_Common1 }



procedure TFR_Test2.Init;
var
i : Integer;
begin
inherited;

// パネルのCaptionを消す
for i := 1 to 10 do
TPanel(FindComponent('Panel' + IntToStr(i))).Caption := ''
end;



procedure TFR_Test2.Proc;
// TColorを指定したOffset分ずらす
function OffsetColor(iColor : TColor; Offset : Smallint) : TColor;
//----------------------------------------------------------------------------
function _offset(iByte : Byte) : Byte;
label _END_;
var
data : Smallint;
begin
data := iByte;
if (Offset > 0) and (data = $FF) then goto _END_;
if (Offset < 0) and (data = $00) then goto _END_;

Inc(data,Offset);

if data > $FF then data := $FF else
if data < $00 then data := $00;

_END_:Result := data;
end;
//----------------------------------------------------------------------------
var
cl : TColor;
cr,cg,cb : Word;
begin
// TColorをBGR毎に分ける
cl := iColor;

// B,G,R
cb := $FF and (cl shr 16); // Blue
cg := $FF and (cl shr 8 ); // Green
cr := $FF and cl; // Red

cb := _offset(cb);
cg := _offset(cg);
cr := _offset(cr);

Result := TColor((cb shl 16) or (cg shl 8) or cr);
end;
var
i : Integer;
c : TColor;
Pnl : TPanel;
begin
inherited;

// 色をグラデーション表示
Self.Color := Random($FFFFFF);
c := Self.Color;
for i := 1 to 10 do begin
Pnl := FindComponent('Panel'+IntToStr(i)) as TPanel;
Pnl.Color := OffsetColor(c,25);
c := Pnl.Color;
end;
end;

end.


[PR]
by yozda | 2011-02-12 22:50 | プログラミング | Trackback | Comments(0)