はじめに
大量のファイルを「指定のサイズ毎」にまとめて振り分けたい!
と思ったことはありませんか?
前々からYahooショッピングへ商品登録を行う際に「手作業で画像サイズを確認しながら圧縮するのが面倒だな-」と思っていたんです。「ファイル サイズ 振り分け 方法」等々の単語で色々検索を掛けてはみるんですが、どうにも目的のツールがヒットしない・・・
※Yahooショッピングでは一度にアップロードできる画像サイズが決まっており、25MBが上限となっています。
きっとどこかに存在はしているんでしょうけど、どこにあるのか見つけられなかったので自分で作りました。
以下ソースコード
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '========================================================== ' 画像を一定のサイズ毎にフォルダに振り分ける '========================================================== Public Sub partedFilesBySize() Dim objFile As Object Dim File_List As Variant Dim lFileSize As Long Dim lTotalSize As Long Dim lLimitSize As Long Dim sTargetFolderPath As String Dim sSaveFolderPath As String Dim sSavePath As String Dim iFolderCnt As Integer Dim sBuf As String ' 実行結果の表示 Dim lCnt As Long Dim lMax As Long sTargetFolderPath = InputBox("振り分け元のフォルダパスを入力して下さい") lLimitSize = InputBox("上限とするサイズを入力して下さい(単位:Mbyte)") * 1000000 If sTargetFolderPath <> "" And lLimitSize > 0 Then MsgBox "処理を開始致します。" & vbCrLf & _ "処理済みのデータはデスクトップ上に保存されます。" sSaveFolderPath = createFolder(CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") & "\processed_img") iFolderCnt = 1 lCnt = 1 With CreateObject("Scripting.FileSystemObject") lMax = .GetFolder(sTargetFolderPath).Files.Count For Each objFile In .GetFolder(sTargetFolderPath).Files Application.StatusBar = lCnt & " / " & lMax & " 件 処理済み" sBuf = objFile.name ' ファイルサイズを取得 lFileSize = FileLen(sTargetFolderPath & "\" & sBuf) ' 以下のいずれかの条件に一致する場合に保存先フォルダを作成する ' 1 : lTotalSize(合計サイズ)の内容が0(ループ開始時)の場合 ' 2 : 合計サイズ + 次ファイルの容量が設定上限を超える場合 If lTotalSize = 0 Or (lTotalSize + lFileSize) > lLimitSize Then sSavePath = createFolder(sSaveFolderPath & "\" & Format(iFolderCnt, "0000")) lTotalSize = lFileSize iFolderCnt = iFolderCnt + 1 Else lTotalSize = lTotalSize + lFileSize End If ' ファイルコピー FileCopy sTargetFolderPath & "\" & sBuf, sSavePath & "\" & sBuf lCnt = lCnt + 1 DoEvents Sleep 1 Next End With End If MsgBox "サイズ振り分けが完了しました!" End Sub '========================================================== ' フォルダ生成 ' 対象のフォルダが既に存在する場合は何もしない '========================================================== Public Function createFolder(path As String) As String If Dir(path, vbDirectory) = "" Then MkDir path End If createFolder = path End Function
機能説明
partedFilesBySizeを実行すると元データの格納されているフォルダパスを聞かれるので、
「C:\Users\hoge\Desktop\img」の様な形で入力して下さい。フォルダ開いてアドレスバーのコピペで大丈夫です。
次にどの位のサイズ毎に振り分けるかを聞かれるので、メガバイト単位で数値を入力して下さい。20MBずつに分けたい場合は「20」と入力するだけでOKです。少数で入力しても問題ありませんが、1バイト未満になる様な入力桁はカットされます。
処理中はエクセルのステータスバー(左下部分)に以下の表示を行いますので、処理件数と残件数が一目で分かる様になっています。
振り分け後のファイルは自動的にデスクトップに保存される様になっています。
「processed_img」というフォルダが作られていますので、中身を確認して見て下さい。
この様な形でフォルダが自動生成されていきます。ちなみにファイルはコピーしているので、元ファイルはそのまま残っています。
今の所自動圧縮機能は付けていないので、各フォルダを開いて手動で圧縮する必要があります。
デスクトップのパスを自動指定するあたりが恐らく環境によってうまく動かないことがあります。(作成環境OS:Windows7)その場合は27行目の
sSaveFolderPath = createFolder(CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") & "\processed_img")
createFolder()内の部分に直接デスクトップのパスを入力するなどして書き換えて下さい。
もう少し改良すればヤフオクストアにも応用できそうですね。ヤフオクストアのアップロード方法ってほんっっっっっっっとうに面倒臭いんですけど、何とかならないんですかね-・・・。
せめてYahooショッピングと同じ様な仕様にしてくれれば・・・。
忙しい人向け:VBSダウンロード
エクセルに組み込む予定は無いしわざわざ作るのも面倒という方向けにスクリプトファイルも用意してみましたので、以下からどうぞ。(処理の進捗を表示する機能は消えています)
zip解凍後、ファイル名の後ろにあるアンダースコア「_」を削除して使用して下さい。
コメント
非常に助かるスクリプト有難うございます。
Windows10使用で、27行目を具体的にどの部分を変えれば良いのでしょうか?
色々試しましたがエラーに成ってしまいます。
仕方が名入りでcreateFolder(“アドレス”)でエラーは回避されましたが、
今度は、MkDir path でエラーに成ります。
宜しくご教授願います。
コメントの確認が遅くなり申し訳ありません!
MkDirという事はExcelVBAの方のソースコードですね。
こちらでソースコードを丸ごとコピーして試して見ましたが、特に問題無く動作する事を確認致しました。
こちらの環境もWindows10ですし特に修正の必要は無いはずですが、エラーにはなんと表示されていますでしょうか。
念のため確認ですが、ソースコードはExcelVBAで動作させるためのものです。
そのままテキストに貼り付けてVBSファイルで保存しても実行は出来ませんが、間違われてはいないでしょうか。
返事ありがとうございます。
説明不足で申し訳ありません。
Exce VBAで動かしています。
少し修正したら、エラーの内容が変わりました。
createFolder(CreateObject(“WScript.Shell”)
↓ へ修正
createFolder(CreateObject(“C:\Users\ihara\Desktop”)
実行時エラー:429
ActiveXコンポーネントはオブシェクトを作成できせん。
と出ます。
宜しくお願い致します。
その修正ではそうなるでしょうね・・・。
なぜその様に修正されたか意図を知りたい所ではありますが、
パスを直書きするのであれば以下の様に変更すれば動くはずです。
sSaveFolderPath = createFolder(“C:\Users\ihara\Desktop\processed_img”)
ご回答、ありがとうございます。
意図はありません。ただ無知なだけです。
正常に動きました。
大変助かります。
これでメールのバックアップが出来ます。
ありがとうございました。