フォルダを作ってそこに移動

Option Explicit

Dim FSYS 'FileSystem
Dim SHAP 'ShellApplication
Dim CurFolder '移動元のディレクトリ
Dim TargetFolderName '移動先のディレクトリ名
Dim TargetFolder '移動先のディレクトリ
Dim file '
Dim MoveFileName '移動対象のファイル
Const FOF_CREATEPROGRESSDLG = &H0&

Set FSYS = WScript.CreateObject("Scripting.FileSystemObject")
Set CurFolder = FSYS.GetFolder(".")
Set SHAP = WScript.CreateObject("Shell.Application")
’ファイル名からフォルダを作ってそこに移動(jpgのみ)
For Each file In CurFolder.Files
TargetFolderName = FolderName(file.Name)
If TargetFolderName <> vbNull Then
If FSYS.FolderExists(TargetFolderName) = False Then
FSYS.CreateFolder(TargetFolderName)
End If
Set TargetFolder = SHAP.Namespace(CurFolder.Path & "\" & TargetFolderName)
'ワイルドカードを使ってまとめてMove
MoveFileName = CurFolder.Path & "\" & TargetFolderName & "*.jpg"
TargetFolder.MoveHere MoveFileName, FOF_CREATEPROGRESSDLG
End If

Next
Set TargetFolder = Nothing
Set CurFolder = Nothing
Set SHAP = Nothing
Set FSYS = Nothing

Function FolderName(FileName)
Dim objRegExp ' 正規表現オブジェクト
Dim Matches ' 検索結果Collection

Set ObjRegExp = New RegExp
ObjRegExp.Pattern = "_.*\d{3}\.jpg" 'jpg のみ対象　xxxx_999.jpg のパターン
ObjRegExp.IgnoreCase = True
ObjRegExp.Global = False
Set Matches = objRegExp.Execute(FileName)

If Matches.Count > 0 Then
FolderName = objRegExp.Replace(FileName,"")
Else
FolderName = vbNull
End If

Set ObjRegExp = Nothing
Set Matches = Nothing

End Function

フォルダの中身をZIP

Option Explicit

Dim FLSYS 'FileSystem
Dim SHLAP 'ShellApplication
Dim WSSHL 'WScriptShell
Dim CurFolder
Dim SubFolder
Dim AddFolder
Const ZipFilePath = "c:\zipped\"
Dim ZipFileName
Dim ZipFile

Dim AddCount
Dim ZipCount

Dim LogFile
Dim LogFileName

Set FLSYS = WScript.CreateObject("Scripting.FileSystemObject")
Set CurFolder = FLSYS.GetFolder(".")

LogFileName = CurFolder.Path
LogFileName = LogFileName & "\"
LogFileName = LogFileName & Mid(Date,1,4) & Mid(Date,6,2) & Mid(Date,9,2)
LogFileName = LogFileName & ".log"
Set LogFile = FLSYS.OpenTextFile(LogFileName,8,True)
LogFile.WriteLine Date & " " & Time & " ##### STRAT CopyToZIP ######"

Set SHLAP = WScript.CreateObject("Shell.Application")
Set WSSHL = WScript.CreateObject("WScript.Shell")

'カレントフォルダ下のサブフォルダ毎にZIPファイルを作ります
For Each SubFolder in CurFolder.SubFolders
LogFile.WriteLine Date & " " & Time & " " & FLSYS.GetFileName(SubFolder.Path)
'カレントディレクトリに同名のZIPファイルが存在していたら削除
ZipFileName = ZipFilePath & FLSYS.GetFileName(SubFolder.Path) & ".zip"
If FLSYS.FileExists(ZipFileName) Then
FLSYS.DeleteFile ZipFileName
End If
FLSYS.CreateTextFile(ZipFileName).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
Set ZipFile = SHLAP.NameSpace(ZipFileName)
ZipCount = ZipFile.Items.Count

'1.　フォルダごと圧縮する場合
' ZipFile.CopyHere(SubFolder.Path)

'2.　フォルダの中身だけ圧縮する場合
'追加するフォルダのオブジェクトを作成
Set AddFolder = SHLAP.NameSpace(SubFolder.Path)
AddCount = AddFolder.Items.Count
LogFile.WriteLine Date & " " & Time & " Copy Start " & ZipCount & "/" & AddCount

ZipFile.CopyHere AddFolder.Items , FOF_NOCONFIRMATION + FOF_SIMPLEPROGRESS
' ZipFile.MoveHere AddFolder.Items , FOF_NOCONFIRMATION + FOF_SIMPLEPROGRESS ' Moveでもファイル残る？

'CopyHere が非同期なので終了を判定
'ファイル数が一致するまで
Do
ZipCount = ZipFile.Items.Count
If ZipCount = AddCount Then Exit Do
WScript.Sleep(3000) '3秒待つ
LogFile.WriteLine Date & " " & Time & " Copy ..... " & ZipCount & "/" & AddCount
Loop
LogFile.WriteLine Date & " " & Time & " Copy End " & ZipCount & "/" & AddCount

Set AddFolder = Nothing
Set ZipFile = Nothing
Next

LogFile.WriteLine Date & " " & Time & " ##### END CopyToZIP ######"
MsgBox "おわり"

Set CurFolder = Nothing
Set SHLAP = Nothing
Set FLSYS = Nothing


ZIPファイルのアイテム数をZipCountに取り出して３秒ごとにログに吐き出してみましたが
ほとんどの場合、０でした。
圧縮中はZipファイルがロックされているようなので、そのせいかな。
Zipファイルの作成される側のフォルダを見ていると、テンポラリファイルが作成されていて、これが時々消えます。

テンポラリファイルが消えたタイミングでアイテム数を取り出すと、
その時点でコピーしたファイルの数が取り出せるようです。
ついでにこのタイミングで一時ロックを解除しているようで、
圧縮処理の終了判定をロックの有無でやるとしくじりがちです。

時々処理が止まってしまいます。エラーメッセージを出してくれる事もあるけど
何にも言わずに待ってるだけの場合、
手でファイルをコピーしてあげると処理を続行できました。

copyhere フォルダ.items でやると隠しファイルは無視されるのかな？
それは具合がいいのでそのまま。
movehere でやっても元のファイルはそのまま残りました。
移動先が圧縮ファイルだから？未検証。
まあ、自動的に消えてしまうのも怖いのでcopyhereで。

zipファイルのサイズが大きくなると１ファイル当たりの処理時間が長くなります。ファイルが育っていくにつれて、だんだん遅くなる感じで、ちょっと考えもの。
そもそもJPEGをさらにZip圧縮してもそんなにメリット無いしにゃーという感じです。