まりふのひと

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

DCIM VBA Tool

　昨日、苦労して「仕分くん」のバッチファイルを完成させたが、チェックが十二分に出来ないことがわかったので、日付が変わるころに起きだし、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