同僚からの依頼でzipファイル格納のVBA検討
最近社内でメールのシステムが変更になり、これまで外部への添付ファイルは自動で「①zipに格納→②パスワード生成→③別メールでパスワードを送付」ができていたのですが、手作業でzipを作成することになりました。
元々パスワード付きzipファイルをメールで送るフロー自体が色々と問題を引き起こす可能性も指摘されているので、その運用自体止めてしまえばよい気もするのですが、セキュリティ対策の主観部署がこれまで行っていたzip格納を止める判断をしなかったらしく上記のように手作業の負担が増えていました。
今回はパスワード付きzipファイルに必要なファイルを連続で圧縮するExcelVBAコードを考えてみました。
zip格納に「LhaPlus」を使用する
以前こちらの記事で紹介していますが、zip格納を安定して実行するためにLhaPlusというフリーソフトを使用します。
Windows標準の機能を呼び出してzip格納をする方法もあるのですが、公式なサポート外らしくエラーが起こるし動作が不安定でした。
LhaPlusはコマンドプロンプトから操作ができるようになっていて、それを利用することでVBAからも自動操作が可能になります。
スポンサーリンク
今回考えた自動zip格納VBAツールの仕組み
今回私が考えたツールの動作と業務のフローは以下の通りです。
事前準備
①zipファイルに格納したいファイルをフォルダごとにまとめてあるフォルダに格納
②zip変換用フォルダをまとめて格納しているフォルダにツールファイルも一緒に格納(vba162_zip一括返還211219.xlsm)
詳細は以下の画像のような状態です。
ツールファイルの画面
ツールファイルは以下のような画面で作成しています。
まずzipを作成するためのフォルダ一覧を取得して、パスワードを手入力したあと、zipを作成するフローを想定しています。
ツール操作実行手順
①フォルダ取得ツールでzipに格納したいフォルダ一覧を取得
「フォルダ取得」ボタンをクリックするとツールフォルダが格納されているフォルダをB1セルに表示し、その中のサブフォルダを一覧にしてA列に取得して入力
②作成するzipファイルのパスワードを入力(B列)
パスワードが規則性のあるものにするならVBAで自動化することもできますが、今回は手入力するフローにしています。
③zip格納ボタンをクリック
サブフォルダの中のファイルが同じ名前のzipに格納され、作成されたサブフォルダ「zip格納」の中にzipファイルが作成される
今回作成したVBAコード
①フォルダ取得
Sub フォルダ取得() Dim FSO As Object, WSH As Object Dim FoldPath As String Dim FolderName As String Dim ArrFolderName() As String Dim i As Long, k As Long Set FSO = CreateObject("Scripting.FileSystemObject") FoldPath = ThisWorkbook.Path Cells(1, 2) = FoldPath i = 0 FolderName = Dir(FoldPath & "\*", vbDirectory) Do While FolderName <> "" If InStr(FolderName, ".") = 0 And FolderName <> "zip格納" Then ReDim Preserve ArrFolderName(i) ArrFolderName(i) = FolderName Cells(i + 4, 1) = FolderName 'Cells(i + 4, 2) = Left(Cells(i + 4, 1), 4) i = i + 1 End If FolderName = Dir() Loop End Sub
②zip格納
Sub サブフォルダzip格納() Dim Cmd As String Dim ArrFileName, FileName Dim FSO, WSH Dim 前FoldPath, 後FoldPath Set FSO = CreateObject("Scripting.FileSystemObject") Set WSH = CreateObject("Wscript.Shell") WSH.CurrentDirectory = "C:\Program Files (x86)\Lhaplus" '前FoldPathに格納されているサブフォルダをzip格納して後FoldPathに格納 前FoldPath = Cells(1, 2) 後FoldPath = Cells(1, 2) & "\zip格納" 'zip格納用のフォルダ作成 If FSO.FolderExists(後FoldPath) = False Then FSO.CreateFolder 後FoldPath 'フォルダ作成 End If '後で使用する対象ファイル一覧表が残っていたら削除 If FSO.FileExists(前FoldPath & "\圧縮リスト.txt") = True Then FSO.DeleteFile 前FoldPath & "\圧縮リスト.txt" End If Dim i i = 4 Do Until Cells(i, 1) = "" ArrFileName = "" FileName = Dir(前FoldPath & "\" & Cells(i, 1) & "\*.*", vbNormal) Do While FileName <> "" If ArrFileName <> "" Then ArrFileName = ArrFileName & vbCrLf & 前FoldPath & "\" & Cells(i, 1) & "\" & FileName Else ArrFileName = 前FoldPath & "\" & Cells(i, 1) & "\" & FileName End If FileName = Dir() Loop 'コマンドプロンプトは文字数の上限があるので、対象ファイル一覧を「圧縮リスト.txt」に入力 With FSO.CreateTextFile(Cells(1, 2) & "\圧縮リスト.txt") .WriteLine ArrFileName .Close End With 'cells(i,2)がPassword 空欄ならパスワード設定なしでzip格納 Cmd = "Lhaplus.exe /c:zip /n:" & 後FoldPath & "\" & Cells(i, 1) & ".zip" & " /p:" & Cells(i, 2).Text & " /l:" & Cells(1, 2) & "\圧縮リスト.txt" WSH.Run "%ComSpec% /c " & Cmd, 7, True FSO.DeleteFile Cells(1, 2) & "\圧縮リスト.txt" i = i + 1 Loop Set FSO = Nothing Set WSH = Nothing End Sub
動作確認の動画とあとがき
今回作成したコードを実行した動画は以下の通りです。
パスワード付きzipファイルをメールで送る文化には賛否両論ありますが、私の会社含めまだまだ根強く残ると思います。
自動サービスがなくなっていってしまう中手作業でこの処理を続けるのは結構つらいと思うので自動処理を考えてみました。
今回ご紹介したコードはコマンドプロンプトを起動している時間PCを使えない(キャンセルしてしまう可能性がある)ので、大量のファイルをzipに格納する場合、別のPCを使うか休憩時間前などに実行だけして休憩時間中に作成することをおすすめします。
おすすめ書籍 (広告)
Amazon 楽天 Yahoo検索 |
---|
Amazon 価格:¥2,420円 |
楽天Kobo電子書籍ストア 価格:2,574円 |
楽天Kobo電子書籍ストア 価格:2,574円 |
bookfanプレミアム 価格:2,420円 |
bookfanプレミアム 価格:2,200円 |
コメント