日記/2008-09-20 - otamachan @ ウィキ

WSH

imageプラグインエラー : 画像を取得できませんでした。しばらく時間を置いてから再度お試しください。

Option Explicit
'-- main --
' グローバル変数
Dim objShell, objShellApp, objFileSys, objFo
Dim objRegEx
Dim strDstFolder, strSrcFolder
Dim intCount, intRet
Dim strExtensionPattern '-- ショートカットを作る拡張子
strExtensionPattern = ".mpg$|.avi$"

Set objRegEx = New RegExp
objRegEx.Global = True  ' 全て検索
objRegEx.IgnoreCase = True  ' 大文字と小文字を区別しない
Set objShell = WScript.CreateObject("WScript.Shell")
Set objShellApp = WScript.CreateObject("Shell.Application")
Set objFileSys = CreateObject("Scripting.FileSystemObject") 

Set objFo = objShellApp.BrowseForFolder(0,"ファイルのあるフォルダを選択して下さい", &h11)
If (objFo Is Nothing) Then
    WScript.Quit
End If
strSrcFolder = objFo.Items.Item.Path

Set objFo = objShellApp.BrowseForFolder(0,"ショートカットを作るフォルダを選択して下さい", &h11)
If (objFo Is Nothing) Then
    WScript.Quit
End If
strDstFolder = objFo.Items.Item.Path

strExtensionPattern = InputBox("以下の正規表現にマッチするファイルのショートカットを作ります．",,strExtensionPattern )
objRegEx.Pattern = strExtensionPattern

intCount = 0
intRet = MsgBox("はじめますか？", 1,"OK?")
If intRet = 1 Then
  createShortCuts strSrcFolder
End If

MsgBox "" & intCount & "個のショートカットを作成しました．",,"Done!"

'-- createShortCuts
Sub createShortCuts(strFolderName)
  Dim objSubFo
  Set objSubFo = objFileSys.GetFolder(strFolderName)    ' 引数に指定されたフォルダの情報を取得
  Dim strFileName
  For Each strFileName In objSubFo.Files
    ' ファイル名チェック
    If objRegEx.Test(strFileName) Then
      Dim objFile, objDate, objShortCut
      Dim strShortCutName
      Set objFile = objFileSys.GetFile(strFileName)
      objDate = DateValue(objFile.DateLastModified)
      strShortCutName = strDstFolder & "\" & _
                      Year(objDate) & "_"  & _
                      Right(00 & Month(objDate), 2) & "_" & _
                      Right(00 & Day(objDate), 2) & _
                      "_(" & objFileSys.GetFileName(strFileName) & ").lnk"
      Set objShortCut = objShell.CreateShortcut(strShortCutName)
      objShortCut.TargetPath = strFileName
      objShortCut.Save
      intCount = intCount + 1
    End If 
  Next
  ' 指定のフォルダに格納された各サブフォルダを処理する
  For Each strFolderName In objSubFo.Subfolders
    createShortCuts(strFolderName)
  Next
End Sub