タグ:SE♂のノウハウ ( 86 ) タグの人気記事
[VBScript] 半角カナを全角へ、全角記号&英数は半角へ変換する関数
どーもボキです。

AdjustStringは
 ・半角カナ → 全角カナ
 ・全角記号 → 半角記号
 ・全角英数 → 半角数字
と変換する関数。

半角カナは、濁点(゛)や半濁点(゜)が別の文字となってしまうため、
今回は、ひとつの関数内で変換元の文字管理と変換処理を行っている。

全角と半角とで文字の並びが統一されていなかったため、
Case文処理が必須だったものの、可能な限り定型処理化した。
a0021757_12555734.gif
SetScriptHost("cscript")

s = "どーもボキです"
dprintf " 前:" & s
dprintf " 後:" & AdjustString(s)
dprintf ""

s = "http://yozda.exblog.jp"
dprintf " 前:" & s
dprintf " 後:" & AdjustString(s)
dprintf ""

s = "2004/05~"
dprintf " 前:" & s
dprintf " 後:" & AdjustString(s)
dprintf ""

' ===============================================================================
' 全角→半角
Function AdjustString(iStr)
Dim i,a1,a0,r,s,s0,s1

i = 1
r = ""
Do While i <= Len(iStr)
a1 = 1
a0 = 0
s0 = ""
s = Mid(iStr, i, 1)
r = s
If ( Asc(s) >= Asc("。") ) And ( Asc(s) <= Asc("゚") ) Then
' 半角カナ → 全角
Select Case s
Case "。" r = "。"
Case "ヲ" r = "ヲ"
Case "ッ" r = "ッ"
Case "ー" r = "ー"
Case Else
If Asc(s) >= Asc("゙") Then
s0="゙": s1="゛": a1=1
ElseIf Asc(s) >= Asc("ワ") Then
s0="ワ": s1="ワ": a1=4
ElseIf Asc(s) >= Asc("ラ") Then
s0="ラ": s1="ラ": a1=1
ElseIf Asc(s) >= Asc("ヤ") Then
s0="ヤ": s1="ヤ": a1=2
ElseIf Asc(s) >= Asc("ム") Then
s0="ム": s1="ム": a1=1
ElseIf Asc(s) >= Asc("マ") Then
s0="マ": s1="マ": a1=1
ElseIf Asc(s) >= Asc("ハ") Then
s0="ハ": s1="ハ": a1=3
If Mid(iStr, i+1, 1) = "゙" Then a0=1
If Mid(iStr, i+1, 1) = "゚" Then a0=2
ElseIf Asc(s) >= Asc("ナ") Then
s0="ナ": s1="ナ": a1=1
ElseIf Asc(s) >= Asc("ツ") Then
s0="ツ": s1="ツ": a1=2
If Mid(iStr, i+1, 1) = "゙" Then a0=1
ElseIf Asc(s) >= Asc("タ") Then
s0="タ": s1="タ": a1=2
If Mid(iStr, i+1, 1) = "゙" Then a0=1
ElseIf Asc(s) >= Asc("カ") Then
s0="カ": s1="カ": a1=2
If Mid(iStr, i+1, 1) = "゙" Then a0=1
ElseIf Asc(s) >= Asc("ア") Then
s0="ア": s1="ア": a1=2
ElseIf Asc(s) >= Asc("ャ") Then
s0="ャ": s1="ャ": a1=2
ElseIf Asc(s) >= Asc("ァ") Then
s0="ァ": s1="ァ": a1=2
ElseIf Asc(s) >= Asc("、") Then
s0="、": s1="、": a1=4
ElseIf Asc(s) >= Asc("「") Then
s0="「": s1="「": a1=1
End If
End Select
ElseIf ( Asc(s) >= Asc(" ") ) And ( Asc(s) <= Asc("z") ) Then
' 全角記号&英数 → 半角
Select Case s
Case " " r=" "
Case "," r=","
Case "." r="."
Case ":" r=":"
Case ";" r=";"
Case "?" r="?"
Case "!" r="!"
Case "^" r="^"
Case "_" r="_"
'Case "ー" r="-" ' 全角文字で利用するため半角変換しない
Case "―" r="-"
Case "‐" r="-"
Case "/" r="/"
Case "\" r="\"
'Case "
" r="~" ' 全角文字で利用するため半角変換しない
Case "
" r="|"
Case "
" r="'"
Case "”" r=""""
Case "(" r="("
Case ")" r=")"
Case "[" r="["
Case "]" r="]"
Case "{" r="{"
Case "}" r="}"
'Case "「" r="「" ' 全角文字で利用するため半角変換しない
'Case "」" r="」" ' 全角文字で利用するため半角変換しない
Case "+" r="+"
Case "-" r="-"
Case "=" r="="
Case "<" r="<"
Case ">" r=">"
Case "′" r="'"
Case "″" r=""""
Case "¥" r="\"
Case "
" r="$"
Case "
" r="%"
Case "
" r="#"
Case "
" r="&"
Case "
" r="*"
Case "
" r="@"
Case Else
If Asc(s) >= Asc("
") Then
s0="
": s1="a"
ElseIf Asc(s) >= Asc("
") Then
s0="
": s1="A"
ElseIf Asc(s) >= Asc("
") Then
s0="
": s1="0"
End If
End Select
End If
If s0 <> "
" Then r=Chr( (Asc(s) -Asc(s0))*a1 +Asc(s1) +a0) ' 変換処理
AdjustString = AdjustString & r

i = i +1 +Abs(CInt(a0 > 0))
Loop
End Function
' ===============================================================================
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
Dim i,s

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """" ' 引数
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
' デバッグ
Dim objDbg
' クラス
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

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(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub
' -------------------------------------------------------------------------------
[VBScript] 全角文字を半角文字へ変換する

[PR]
by yozda | 2017-08-18 20:40 | プログラミング | Trackback | Comments(0)
[VBScript] 全角英数&記号を半角へ変換する
どーもボキです。

定型業務のツール支援するにも、文字バイトが統一されていないとそれすらままならない。
そういうときは、以下のZenToHan関数で文字サイズを半角に統一するとよい。
a0021757_09255103.png
ZenToHan関数での変換事例

SetScriptHost("cscript")

s = "yozda ( … > Z_ ̄∂ "
dprintf " 前:" & s
dprintf " 後:" & ZenToHan(s)

' ===============================================================================
' 全角→半角
Function ZenToHan(iStr)
Dim i,r

r = ""
For i = 1 To Len(iStr)
r = r & ZenToHan_func(Mid(iStr, i, 1))
Next
ZenToHan = r
end function
' 関数
Function ZenToHan_func(iStr)
Dim r
r = iStr
ZenToHan_func = r
If Asc(r) < Asc(" ") Then Exit Function
If Asc(r) > Asc("z") Then Exit Function

Select Case r
Case " " r = " "
Case "," r = ","
Case "." r = "."
Case ":" r = ":"
Case ";" r = ";"
Case "?" r = "?"
Case "!" r = "!"
Case "^" r = "^"
Case "_" r = "_"
Case "ー" r = "-"
Case "―" r = "-"
Case "‐" r = "-"
Case "/" r = "/"
Case "~" r = "~"
Case "|" r = "|"
Case "’" r = "'"
Case "”" r = """"
Case "(" r = "("
Case ")" r = ")"
Case "[" r = "["
Case "]" r = "]"
Case "{" r = "{"
Case "}" r = "}"
Case "+" r = "+"
Case "-" r = "-"
Case "=" r = "="
Case "<" r = "<"
Case ">" r = ">"
Case "′" r = "'"
Case "″" r = """"
Case "¥" r = "\"
Case "
" r = "$"
Case "
" r = "%"
Case "
" r = "#"
Case "
" r = "&"
Case "
" r = "*"
Case "
" r = "@"
Case Else
If Asc(r) >= Asc("
") Then
r = Chr(Asc(r) -Asc("
") +Asc("a"))
ElseIf Asc(r) >= Asc("
") Then
r = Chr(Asc(r) -Asc("
") +Asc("A"))
ElseIf Asc(r) >= Asc("
") Then
r = Chr(Asc(r) -Asc("
") +Asc("0"))
End If
End Select
ZenToHan_func = r
End Function
' ===============================================================================
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
Dim i,s

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """" ' 引数
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋してもOK
Dim objDbg
' クラス
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

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(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub



[PR]
by yozda | 2017-08-16 22:11 | プログラミング | Trackback | Comments(0)
[VBScript] ブラウザでのダウンロードダイアログ操作を自動化する。
こんにチワワ。どーもボキです。

a0021757_1545294.png
Firefoxでは、ZIPファイルなどのリンクをクリックすると、
「***を開く」というタイトルのダイアログが表示されるため、ダウンロードはユーザ操作が必要。
(IEでは、「ファイルのダウンロード」。Chromeではダイアログが表示されることなくダウンロードが始まる)

そのユーザ操作を自動化するスクリプト。
1.「***を開く」というタイトルのウィンドウがある場合は、それを最前面に移動する。
2.Alt+Sで、「ファイルを保存する」を選択する。
3.Enterで、ダイアログを閉じる。

実行状態がわかるように、CScriptで実行させている。
実行ホストの切り替えには、[VBScript] 引数を引き継いだ上で、指定したホストで実行するを使った
SetScriptHost("CScript")    ' CScriptで実行

Set objWS = WScript.CreateObject("WScript.Shell")
While True
If objWS.AppActivate("を開く") Then
WScript.StdOut.WriteLine "実行"
WScript.Sleep 500
objWS.SendKeys "%(S)" ' 保存するボタンにフォーカス
WScript.Sleep 500
objWS.SendKeys "{ENTER}" ' 保存するボタンを押下
End If
WScript.Sleep 1000
Wend
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
If InStr(LCase(WSCript.FullName),LCase(HostName)) <> 0 Then Exit Sub

s = HostName & " """ & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &" """ & WScript.Arguments.Item(i) & """"
Next
End If
CreateObject("WScript.Shell").Run s
WScript.Quit
End Sub



[PR]
by yozda | 2016-06-25 15:46 | プログラミング | Trackback(1) | Comments(0)
[Excel] 文字入力のみで自動色分けするスケジュールフォーマットを作成する
こんにチワワ。どーもボキです。

Excelブックを共有設定した場合、複数ユーザからセルへの文字入力は可能なものの、
図形(オートシェイプ)編集はできなくなる。

そのため、図形を使わず、セルへの文字入力のみスケジュールを作成する方法を紹介する。
またこの方法ならば、図形を使うよりも、日程の延長/短縮や色分けの編集も簡単に行える。
a0021757_21331285.gif
スケジュールのイメージ(■や★の記入のみで色分けされる)


以下を利用し実現する。
 ・ワークシート関数
 ・記号文字(■、●、★など)
 ・条件付き書式 機能

a0021757_14315029.gif
左列を参照する数式を入力する。(参照先がブランクの場合、参照元セルが「0」を表示)

a0021757_14314312.gif
参照先セルに「=""」を入力すれば、参照元セルもブランク表示となる。

a0021757_14313589.gif
■や★を入力し、スケジュールを書く。★の右列(P2)には、「=""」を入力)

a0021757_14312929.gif
条件付き書式を設定し、■であり、=左列ならば、フォント(文字)とパターン(塗りつぶし)に同じ色を指定する。

a0021757_14312376.gif
同様に、「■であり、≠左列」と「★である」条件での書式を追加する。

a0021757_14311899.gif
文字入力のみで、該当箇所が塗りつぶされるスケジュールフォーマットが完成。


Excel2003の場合、条件付き書式は3つまでに対し、2007以降は無制限となっている。

そのため、条件付き書式を使い「=0」の場合は、フォントの色を白にするとしておけば、
参照先が「0」と表示されても見えないので問題ない。(「=""」の入力が不要)

また、より多くの記号を使い、細かなスケジュールを作成することができる。


[PR]
by yozda | 2016-05-14 14:49 | プログラミング | Trackback | Comments(0)
[VBScript] 管理者昇格してスクリプトを実行する 【改良版】
こんにちわわ。どーもボキです。

ExecRunas関数内でWScript.Quitすれば、前回バージョンのような判定処理は不要になるね。

実行部
' 管理者権限でVBSを実行する
ExecRunas

' ~管理者権限で実行したいソース~


実装部
'--------------------------------------------------------------------------------------------------------
'OSのバージョンを取得する
Const osWinNT = 4.0
Const osWin2k = 5.0
Const osWinXP = 5.1
Const osVista = 6.0
Const osWin7 = 6.1
Const osWin8 = 6.2
Function GetOSVersion
Dim objWMI, osInfo, os

Set objWMI = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set osInfo = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem")
For Each os in osInfo
GetOSVersion = CDbl(Left(os.Version, 3))
Next
End Function
'--------------------------------------------------------------------------------------------------------
' 管理者に昇格して実行する
Function ExecRunas
Const cKey = "/ExecRunas"
Dim s

' ExecRunas実行チェック'
If WScript.Arguments.Count > 0 Then
If WScript.Arguments.item(0) = cKey Then Exit Function
End If

' OSバージョンチェック'
If GetOSVersion < osVista Then Exit Function

' 引数を生成'
s = ""
For i = 0 To WScript.Arguments.Count -1
s = s & " """ & WScript.Arguments.item(i) & """"
Next

' Runas実行'
CreateObject("Shell.Application").ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """" & " " &cKey& " " & s, "", "runas", 1

' VBS実行を終了'
WScript.Quit
End Function
'--------------------------------------------------------------------------------------------------------

[VBScript] 管理者昇格してスクリプトを実行する
[PR]
by yozda | 2015-12-20 15:37 | プログラミング | Trackback | Comments(0)
[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)
サーバへのウィルス侵入を許してしまった
こんばんワイン。どーもボキです。

会社のサーバにウィルスが侵入した。図はその経路。

設備付属のローカルPCにはウィルス対策ソフトが入っていない。
そのため、マカフィー導入済みの管理PCで、ローカルPC~サーバ間の共有フォルダを中継させている。

この中継により、上流のネットワークとなるサーバやイントラへのウィルス侵入を防げる、
と思っていた。が、サーバへのウィルス侵入を許してしまった。

後の調査で、スキャン設定でネットワークドライブのスキャンがOFFとなっていたことが分かった。

つまり、ローカル ⇒ サーバ と共有フォルダの中継のみを行う場合、管理PC上でコピー処理が動くものの、
マカフィー上は、あくまでもネットワークドライブ上の話となる。つまりスキャン対象外。

ちなみに、ネットワークドライブへのスキャンをONにすると、
共有フォルダを利用するたびにスキャンされ、トラフィックを食いつぶしてしまうらしい。

今回の場合、管理PCでのウィルスチェックを機能させるには、
ローカルPCのファイルは、いったん管理PC上に保存させるしかない。
a0021757_1929610.gif



[PR]
by yozda | 2015-05-04 22:53 | SE♂日誌 | Trackback(2) | 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)