カテゴリ:プログラミング( 101 )
[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)
[VBScript] ラジオボタンダイアログを実現する その4
おはヨーグルト。どーもボキです。

IE11でonclickを検出しない問題。解決した。
onclick=Button.Value=1 ⇒ onclick=Form.Button.Value=1
とすればいい。
a0021757_931857.gif


以下ソース。nclick と Documentを半角にすること。
RadioGroupBox_MaxCount = 10
r = RadioGroupBox("タイトル","キャプション","アイテム0,アイテム1,アイテム2",1)
MsgBox r
'-----------------------------------------------------------------------------------------
' sTitle : タイトル
' sCaption : メッセージ
' RadioItems : ラジオアイテムリスト (配列)
' DefaultIndex : デフォルト選択するアイテムインデックス
Function RadioGroupBox(sTitle, sCaption, RadioItems, DefaultIndex)
Dim objIE,ieDoc,disp_h,disp_w
Dim i,s,r,html,bCmbBx

r = -1
If Not IsArray(RadioItems) Then RadioItems = Split(RadioItems,",")

' IEを起動
Set objIE = WScript.CreateObject("InternetExplorer.Application")
objIE.Navigate "about:blank"

' タグ記述
html = "<BODY><TABLE ID=Tbl BORDER=0 STYLE=font-size:10pt>" & _
"<TR><TD ALIGN=Left VALIGN=Top><SPAN>" & Replace(sCaption,vbCRLF,"<BR>") & "</SPAN>" & _
"<FORM NAME=Form>" & _
"<INPUT TYPE=HIDDEN NAME=Button Value=-1></FORM>"
bCmbBx = UBound(RadioItems) >= RadioGroupBox_MaxCount-1
If bCmbBx Then
' コンボボックス
html = html +"<SELECT NAME=ComboBox size=" & RadioGroupBox_MaxCount &" style=width:100%>"
For i = 0 To UBound(RadioItems)
If i = DefaultIndex Then s = " selected" Else s = ""
html = html +"<OPTION value=" & i & s & ">" & RadioItems(i) &"</OPTION>"
Next
s = s+"</SELECT>"
Else
' ラジオボタン
html = html +"<INPUT NAME=Radio TYPE=HIDDEN VALUE="& DefaultIndex & ">"
For i = 0 to UBound(RadioItems)
If i = DefaultIndex Then s = " checked" Else s = ""
html = html +" <INPUT TYPE=RADIO Name=RG onclick=Radio.value=" & i & s & ">" & RadioItems(i) &"</INPUT><BR>"
Next
End If
html = html +"<BR></TD></TR><TR><TD ALIGN=Center VALIGN=Bottom>"&_
"<INPUT TYPE=BUTTON VALUE=""  OK  "" onclick=Form.Button.Value=1> " & _
"<INPUT TYPE=BUTTON VALUE=""キャンセル"" onclick=Form.Button.Value=0;Form.Radio.Value=-1>" & _
"</TD></TR></FORM></TABLE></BODY>"


' ↓↓共通↓↓
objIE.Document.Body.InnerHtml = html
objIE.Document.Title = sTitle
Call GetResolution(disp_h, disp_w) ' 解像度取得
objIE.Toolbar = 0 ' 上ツールバーを隠す
objIE.StatusBar = False ' 下ステータスバーを隠す
objIE.Document.Body.RuntimeStyle.OverflowX = "hidden" ' 横 スクロールバーを隠す
objIE.Document.Body.RuntimeStyle.OverflowY = "hidden" ' 縦 〃
objIE.Width = objIE.Document.All.Tbl.clientWidth +50 ' 幅 サイズ調整
objIE.Height = objIE.Document.All.Tbl.clientHeight +70 ' 高 〃
objIE.Left = Int((disp_w -objIE.Width )/2) ' 左 位置調整
objIE.Top = Int((disp_h -objIE.Height)/2) ' 上 〃
For i = 0 To objIE.Width
objIE.Document.Title = objIE.Document.Title +" " ' - Microsoft Internet Explorerを隠す
i = i +10
Next
objIE.Document.Body.bgcolor = "ButtonFace" ' 色
objIE.Visible = True ' ウィンドウ表示
objIE.Resizable = False ' ウィンドウサイズ固定 ※表示前に実行すると縁にゴミ画像が残る
' ユーザ操作取得
On Error Resume Next ' エラー無視 ([×]終了対応)
Set ieDoc = objIE.Document
Do While r = -1
WScript.Sleep 100
r = CInt(ieDoc.Form.Button.Value)
If objIE = Null Then Exit Do
Loop
objIE.Visible = False
' ↑↑共通↑↑

' 値取得
If bCmbBx Then
If CInt(ieDoc.Form.Button.value) = 1 Then
r = ieDoc.Form.ComboBox.selectedIndex
Else
r = -1
End If
Else
r = CInt(ieDoc.Form.Radio.value) ' 取得データは文字のため
End If
RadioGroupBox = r
objIE.Quit
Set objIE = Nothing
On Error GoTo 0 'エラー無視を解除
End Function

'-----------------------------------------------------------------------------------------
' 解像度を取得
Sub GetResolution(ByRef wHeight, ByRef wWidth)
Dim Locator,Service,OfeSet

Set Locator = WScript.CreateObject("WbemScripting.SWbemLocator")
Set Service = Locator.ConnectServer
Set QfeSet = Service.ExecQuery("Select * From Win32_VideoController")
For Each Qfe In QfeSet
If Qfe.CurrentHorizontalResolution <> nil then ' 複数ディスプレイ出力PC対応
wWidth = Qfe.CurrentHorizontalResolution
wHeight= Qfe.CurrentVerticalResolution
End If
Next
End Sub
[VBScript] ラジオボタンダイアログを実現する その3

[PR]
by yozda | 2014-12-29 09:29 | プログラミング | Trackback | Comments(3)
[VBScript] 更新日時を元にファイルをリネームする
こんばんワイン。どーもボキです。

iPhoneに限った話ではないが、デバイスの保存画像ファイルをすべて吸い上げると、
ファイル名がリセットされ、また同じ名前でファイルが作られる。

同じ名前のファイルが存在する場合、同じフォルダに保存できず不便なため、
ファイルの更新日時情報からファイル名を変更するスクリプトを作成した。

使い方は、以下の実行プログラムをメモ帳にペーストし、vbsファイルとして保存、実行するだけ。
図のようにフォルダ選択ダイアログが表示される。

なお、VBSファイルへのフォルダ/ファイルドロップでも処理可能。
a0021757_13225160.gif
実行プログラム
'==============================================================================='
Set objWS = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count = 0 Then
If Not SelectDirectory("処理するフォルダを選択",0,dpth) Then WSCript.Quit

objWS.Run "CScript """ & WScript.ScriptFullName & """ """ & dpth & """"
WScript.Quit ' 引数を渡し再起動
Else
SetScriptHost("CScript") ' ドロップだとWScriptとなるためCScriptで再起動

For i = 0 To WScript.Arguments.Count -1: Do
s = WScript.Arguments.Item(i)

If objFS.FileExists(s) Then
ProcFile(s)
Else
SearchFile(s)
End If
Loop Until 1: Next
End If

r = objWS.PopUp("処理が終了しました。",3,"終了メッセージ",64)
'================================================================================

' -------------------------------------------------------------------------------
' フォルダ内のファイル検索
Sub SearchFile(DPath)
Set Folder = objFS.GetFolder(DPath)

' フォルダ内のフォルダ
For Each SubFolder In Folder.SubFolders: Do
SearchFile(SubFolder.Path)
Loop Until 1: Next

' フォルダ内のファイル
For Each File In Folder.Files: Do
ProcFile(File.Path)
Loop Until 1: Next
End Sub
' -------------------------------------------------------------------------------'
' ファイル処理本体
Function ProcFile(FPath)
Dim i,s,ttl,ext,dpth,dnam,fnam0,fnam,fpth
ProcFile = False
'If LCase(Right(FPath, Len(FPath) -InStrRev(FPath,"."))) <> "csv" Then Exit Function

dpth = objFS.GetParentFolderName(FPath) &"\"
'dnam = objFS.GetFileName(objFS.GetParentFolderName(FPath))
fnam0 = objFS.GetFileName(FPath)

s = objFS.GetFile(FPath).DateLastModified
'If Len(s)=18 Then s = Replace(s, "
", " 0") ' h→hh
ttl = Mid(s,3,2) & Mid(s,6,2) & Mid(s,9,2) ' yymmdd
ext = Right(FPath, Len(FPath) -InStrRev(FPath,"
.") +1) ' 拡張子

fnam = ttl & ext
fpth = dpth & fnam
If objFS.FileExists(fpth) Then
i = 1
fnam = ttl &"
_"& IntToStr0(i,1) & ext
fpth = dpth & fnam
While objFS.FileExists(fpth)
i = i+1
fnam = ttl &"
_"& IntToStr0(i,1) & ext
fpth = dpth & fnam
Wend
End If
dprintf(fnam0 &"
"& fnam)
objFS.GetFile(FPath).Name = fnam

ProcFile = True
End Function
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
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
'-------------------------------------------------------------------------------
' フォルダ選択ダイアログ
Function SelectDirectory(sCaption, sInitDir, sSelectDir)
Dim objFS,objSA,dpth

SelectDirectory = False
Set objFS = CreateObject("
Scripting.FileSystemObject")
Set objSA = CreateObject("
Shell.Application")

Set objFolder = objSA.BrowseForFolder(0, sCaption, 0, sInitDir)
If objFolder Is Nothing Then Exit Function ' キャンセル

If objFolder.Items.Item Is Nothing Then
dpth = CreateObject("
WScript.Shell").SpecialFolders("Desktop") &"\" ' デスクトップ
Else
dpth = objFolder.Items.Item.Path &"
\"
End If
If Not objFS.FolderExists(dpth) Then Exit Function '指定異常 (ゴミ箱とか)

sSelectDir = dpth
SelectDirectory = True
End Function
'-------------------------------------------------------------------------------
' 0付き文字に変換
Function IntToStr0(Value, Digits)
Dim i,cnt,s

s = CStr(Value)
cnt = Digits - Len(s)
For i = 0 To cnt
s = "
0" & s
Next
IntToStr0 = s
End Function
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋しても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 | 2014-12-13 17:46 | プログラミング | Trackback | Comments(0)
[VBScript] 指定時間経過後にPCをスタンバイにする
こんばんワイン。どーもボキです。

PCをスタンバイにするで紹介したもの使った。
Excel未インストールの場合には、SendKeyを利用するようにしている。

何かしらの処理(○○な動画ダウンロード・変換など)で一定時間後にPCを切りたいときなどに利用できそう。
a0021757_23433621.gif
s = InputBox("hh:mm形式","指定時間後にスタンバイ","00:10")
If s = "" Then WScript.Quit

t = CDate(s) + Time
While CDate(t) > Time
WScript.Sleep(10000)
Wend

Set objWS = CreateObject("WScript.Shell")
r = objWS.PopUp("スタンバイにします。",3,"確認",vbOKCancel)
If r = vbCancel then WScript.Quit

On Error Resume Next ' Excel未インストール対応
Set objExcel = CreateObject("Excel.Application")
On Error GoTo 0
If Not (objExcel Is Nothing) Then
' Excelあり
cmd = "CALL(""powrprof.dll"",""SetSuspendState"",""JJJJ"",0,0,0)" '1,0,0とすると休止
objExcel.ExecuteExcel4Macro(cmd)
objExcel.Quit ' Quitしないとプロセスが残るため
Else
' Excelなし ⇒ タスクマネージャーを起動
objWS.SendKeys "^+{esc}" ' タスクマネージャー起動
Do While Not objWS.AppActivate("Windows タスク マネージャ")
WScript.Sleep 250 ' タスクマネージャー起動待ち
Loop
WScript.Sleep 1000

' ショートカットキーを送信
objWS.SendKeys "%ub%fx" ' スタンバイ
'objWS.SendKeys "%uh%fx" ' 休止状態
'objWS.SendKeys "%uu%fx" ' シャットダウン
'objWS.SendKeys "%ur%fx" ' 再始動
'objWS.SendKeys "%ul%fx" ' ログオフ
End If

[VBScript] Craving Explorerの動画変換の終了後、PCをスタンバイにする

[PR]
by yozda | 2014-11-22 23:46 | プログラミング | Trackback | Comments(0)
シャープ携帯の電話帳エディタ
むかーし作ろうと思ってフォーマット解析してた資料。
a0021757_2352646.jpg

[PR]
by yozda | 2014-11-17 08:47 | プログラミング | Trackback | Comments(0)
[VBScript] デバッグ上手はプログラム上手6 ~まとめ改~
こんにチワワ。どーもボキです。

以下と組み合わせれば、実行時にホストを変更でき、デバッグが楽になる。
引数を引き継いだ上で、指定したホストで実行する

前回はデバッグクラスを自分で生成するようにしていたが、
今回の記事では、最初にdprintf()を実行したタイミングで自動生成するよう改良した。

配布時は、SetScriptHostのみコメントアウトすればよい。
デフォルトであるWScriptホストでは、デバッグメッセージが表示されないようにしているので。

プログラムとその実装例
SetScriptHost("CScript")
dprintf("デバッグモード")

' ↑上記にスクリプト本体を記載する
' ===============================================================================
' デバッグ
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
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
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
objWS.Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
[VBScript] デバッグ上手はプログラム上手5 ~まとめ~

[PR]
by yozda | 2014-08-24 14:48 | プログラミング | Trackback | Comments(0)
[VBScript] 管理者昇格してスクリプトを実行する
こんばんワイン。どーもボキです。

Win7以降(Vista以降?)、管理者でのログインといえど、
プログラムが管理者権限で実行されるわけではない。これはスクリプトも同じ。

管理者権限で実行するならば、右クリック > 管理者として実行する。
これをしなければ、スクリプトでレジストリの書き換えすら出来ない。

PBPには、ボタン押す以外は困難を極めるため、こういった高度な操作は期待できない。

なので、スクリプト内でOSを判定させ、Win7以降の場合は、
勝手に管理者に昇格して、スクリプトを実行しなおす仕組みを用意した。

なお、Win7以前は管理者ログインで実行されたプロセスは管理者権限で動作するため、
OSバージョンがWin7以前の場合は、何もしないようにしている。

実行部
' 管理者権限でVBSを実行する
If ExecRunas Then WScript.Quit

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


実装部
'--------------------------------------------------------------------------------------------------------
'OSのバージョンを取得する
Const osWinNT = 4.0
Const osWin2k = 5.0
Const osWinXP = 5.1
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 = False

' OS情報を取得'
If GetOSVersion < osWin7 Then Exit Function

' 引数の処理'
s = ""
If WScript.Arguments.Count > 0 Then
If WScript.Arguments.item(0) = cKey Then Exit Function ' 実行済み'

For i = 0 To WScript.Arguments.Count -1
s = s & " """ & WScript.Arguments.item(i) & """"
Next
End If

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

ExecRunas = True
End Function
'--------------------------------------------------------------------------------------------------------



[PR]
by yozda | 2014-04-29 23:59 | プログラミング | Trackback(1) | Comments(0)