「仕分くん」をExcel VBA化し「マクロ仕分くん」とした(マクロの中で仕分ちゃんを起動)

 昨日、苦労して「仕分くん」のバッチファイルを完成させたが、チェックが十二分に出来ないことがわかったので、日付が変わるころに起きだし、Excel2010で VBA化した。まだ改善の余地があるが、検証した結果、目的どおり動いたのでひとまず完成とした。
取扱説明書は大胆な挑戦をした人に作ってもらうことにしたい...

マクロ仕分くんのソース


 まだ汚いが今後の改修のために載せた。

  1. Option Explicit 
  2. Const ShiwakeExe = "D:\Download\仕分ちゃん\shiwake.exe" 
  3. '引用元:http://www.moug.net/tech/exvba/0150034.html 
  4. '--- Win32 API 関数の宣言 --- 
  5. Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _ 
  6. ByVal dwMilliseconds As Long) As Long 
  7. Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _ 
  8. ByVal bInheritHandle As Long, _ 
  9. ByVal dwProcessId As Long) As Long 
  10. Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 
  11.  
  12. '--- Win32 API 定数の宣言 --- 
  13. Public Const PROCESS_ALL_ACCESS As Long = &H1F0FFF 
  14. Public Const INFINITE As Long = &HFFFF 
  15.  
  16. ' INIファイル文字列情報取得関数(API)の定義 
  17. Public Declare Function GetPrivateProfileString Lib "kernel32" _ 
  18. Alias "GetPrivateProfileStringA" _ 
  19. (ByVal lpApplicationName As String, _ 
  20. ByVal lpKeyName As Any, _ 
  21. ByVal lpDefault As String, _ 
  22. ByVal lpReturnedString As String, _ 
  23. ByVal nSize As Long, _ 
  24. ByVal lpFileName As String) As Long 
  25.  
  26. Dim STRAns As String 
  27. Dim VARAns As Variant 
  28.  
  29. Sub Auto_Open() 
  30. Dim mbTitle As String 
  31. Dim i As Long 
  32. Dim shiwakeFolder As String 
  33. Dim shiwakeSaki As String 
  34.  
  35. mbTitle = "Auto_Open/" & ThisWorkbook.Name 
  36. shiwakeFolder = getFolderName() 
  37. If shiwakeFolder = "" Then Exit Sub 
  38. i = InStrRev(shiwakeFolder, "\") 
  39. If i = 0 Then GoTo Exit_AutoOpen 
  40. STRAns = Mid(shiwakeFolder, i + 1) 
  41. If STRAns <> "DCIM" Then 
  42. MsgBox "このフォルダーは仕分けることはできません。" & vbCrLf & vbCrLf _ 
  43. & "フォルダー名=" & shiwakeFolder, vbCritical, mbTitle 
  44. GoTo Exit_AutoOpen 
  45. End If 
  46. Call runShiwake(shiwakeFolder) 
  47. shiwakeSaki = getShiwakeSaki() 
  48. Call runExplorer(shiwakeSaki) 
  49.  
  50. Exit_AutoOpen: 
  51. Application.Quit 
  52. ThisWorkbook.Close 
  53.  
  54. End Sub 
  55.  
  56. ' INIファイルから文字列情報を取得する関数 
  57. ' 返り値:取得データ 
  58. ' 引き数:FName - .iniファイル名 
  59. '     SName - セクション名 
  60. '     KName - キー名 
  61. '     Default - 取得に失敗したときや該当する項目が無かった時の戻り値 
  62. Public Function ReadIni(ByVal FName As String, ByVal SName As String, _ 
  63. ByVal KName As String, ByVal default As String) As String 
  64. Dim RtnCD As Long 
  65. Dim RtnStr As String 
  66.  
  67. ' GetPrivateProfileString APIを利用し、INIファイルから情報取得 
  68. RtnStr = Space$(256) 
  69. RtnCD = GetPrivateProfileString(SName, KName, default, RtnStr, 255, _ 
  70. FName) 
  71.  
  72. ' 戻り値設定 
  73. If RtnCD > 0 Then 
  74. If InStr(RtnStr, Chr$(0)) > 0 Then 
  75. ReadIni = Left$(RtnStr, InStr(RtnStr, Chr$(0)) - 1) 
  76. Else 
  77. ReadIni = "" 
  78. End If 
  79. Else 
  80. ReadIni = default 
  81. End If 
  82.  
  83. End Function 
  84.  
  85. Function getShiwakeSaki() As String 
  86. Const iniName = "settings.ini" ' INIファイル名 
  87. Const secName = "settings"     ' セクション名 
  88. Const keyName = "001"      ' キー名 
  89. Const default = ""       ' デフォルト値 
  90. Dim i As String 
  91. Dim iniFileName As String 
  92.  
  93. iniFileName = ThisWorkbook.Path & "\files\" & iniName 
  94. STRAns = ReadIni(iniFileName, secName, keyName, "") 
  95. i = InStrRev(STRAns, "\") 
  96. getShiwakeSaki = Left(STRAns, i - 1) 
  97.  
  98. End Function 
  99.  
  100. '引用:http://www.moug.net/tech/exvba/0150086.html
  101. Sub runExplorer(argFolder As String) 
  102. Dim environmentString As String 
  103. Dim i As Long 
  104.  
  105. i = 1 
  106. Do 
  107. environmentString = Environ(i) 
  108. If Left(UCase(environmentString), 7) = "WINDIR=" Then 
  109. STRAns = Mid(environmentString, 8, Len(environmentString)) 
  110. Exit Do 
  111. End If 
  112. i = i + 1 
  113. Loop Until Environ(i) = "" 
  114. VARAns = Shell(STRAns & "\Explorer.exe /e, " & argFolder, vbNormalFocus) 
  115.  
  116. End Sub 
  117.  
  118. Sub runShiwake(argPath As String) 
  119. Dim TaskId As Long     'タスクID 
  120. Dim hProc As Long     'プロセスハンドル 
  121.  
  122. ' 外部プログラムの実行 
  123. TaskId = Shell(ShiwakeExe & " " & argPath, vbNormalFocus) 
  124. ' プロセスハンドルの取得 
  125. hProc = OpenProcess(PROCESS_ALL_ACCESS, 0, TaskId) 
  126. ' プロセスハンドルが返されたかを判定 
  127. If hProc <> 0 Then 
  128. ' プロセスのシグナル待ち 
  129. Call WaitForSingleObject(hProc, INFINITE) 
  130. 'プロセスクローズ 
  131. CloseHandle hProc 
  132. End If 
  133. End Sub 
  134.  
  135. Function getFolderName() As String 
  136. With Application.FileDialog(msoFileDialogFolderPicker) 
  137. If .Show = True Then 
  138. getFolderName = .SelectedItems(1) 
  139. End If 
  140. End With 
  141.  
  142. End Function