本当に初心者なので、質問自体がおかしかったら申し訳ありません。

本当に初心者なので、質問自体がおかしかったら申し訳ありません。 outlookで受信した複数のメールに添付されている、パスワード付きのzipファイルを解凍し、デスクトップ上の指定フォルダに保存したいです。 ・メールは○○○というフォルダに自動振り分けされてます。 ・メール1通につきパスワード付きzipファイルが1つ添付されております。 ・パスワードは全て共通で×××です。 ・デスクトップの△△△というフォルダへ解凍して保存したいです。 ・解凍ソフトはLhaplusです。 毎日30通ほど地道に解凍保存しており大変なのでお知恵をお借りしたいです。 自分なりに検索してみたのですが、お手上げでした。 コピペして、×××、○○○、△△△の部分を修正するだけて済むようなVBAのコードをご教示下さい。

Visual Basic | メール66閲覧xmlns="http://www.w3.org/2000/svg">500

ベストアンサー

0

>・デスクトップの△△△というフォルダへ解凍して保存したいです。 当方Windows10、Offce2019ですが、デスクトップでは解凍でエラーが出てしまいました。OneDriveあたりが原因かと思いますが、対処方法まで探せなかったので、別のフォルダにさせて下さい。 また、添付ファイルは一旦保存しないと処理出来ないので、解凍するフォルダに一旦保存して処理後削除しています。 固定部分は先頭のConstで設定して下さい。 テストしてみて、稀にパスワード入力を自動処理が間に合わない?のか手入力の画面が表示されてしまうことがありました。 これも原因と対処方法はまだです。 一度テストしてみて、不具合をお知らせ下さい。 その際はお使いのOSとエクセルのバージョンも書いて下さい。 Sub test() Const con1 As String = "○○○" '自動振分フォルダ名 Const con2 As String = "xxx" 'zipファイルのパスワード Const con3 As String = "D:\test" '解凍先フォルダ名 Dim olObj As Outlook.Application Dim wkSpace As Object Dim infol As Folder Dim subFol As Folder Dim oItem As Object Dim i As Long Dim atno As Integer Dim j As Integer Dim FSO As Object Dim fileObj As Object Dim shellObj As Object Dim zipObj As Variant Dim ret As Long Dim WSC As Object Set olObj = CreateObject("Outlook.Application") Set wkSpace = olObj.GetNamespace("MAPI") '受信トレイ Set infol = wkSpace.GetDefaultFolder(6) 'サブフォルダー指定 Set subFol = infol.Folders(con1) For i = 1 To subFol.Items.Count Set oItem = subFol.Items(i) With oItem '添付zipファイルがあれば一旦保存 atno = .Attachments.Count If atno <> 0 Then For j = 1 To atno If InStr(.Attachments(j).DisplayName, "zip") > 0 Then .Attachments(j).SaveAsFile (con3 & "\" & .Attachments(j).DisplayName) End If Next j End If End With Next i '保存したzipファイルを解凍 i = 0 Set FSO = CreateObject("Scripting.FileSystemObject") Set shellObj = CreateObject("Shell.Application") For Each fileObj In FSO.GetFolder(con3 & "\").Files '拡張子のチェック If FSO.GetextensionName(fileObj) = "zip" Then Set zipObj = shellObj.Namespace(fileObj.Path).Items Application.SendKeys con2 & "{Enter}" ret = shellObj.Namespace(con3).CopyHere(zipObj) If ret > 0 Then MsgBox "解凍に失敗しました。", 48 Exit Sub End If i = i + 1 End If Next fileObj 'zipファイル削除 Kill con3 & "\*.zip" 'SendKeysでNumLockが外れるのを回避 Set WSC = CreateObject("WScript.Shell") WSC.SendKeys "{NUMLOCK}" Set WSC = Nothing Set olObj = Nothing Set wkSpace = Nothing Set infol = Nothing Set subFol = Nothing Set oItem = Nothing Set FSO = Nothing Set shellObj = Nothing Set fileObj = Nothing Set zipObj = Nothing MsgBox i & "個のzipファイルを解凍しました" End Sub

この返信は削除されました

ThanksImg質問者からのお礼コメント

回答頂きありがとうございます。 一旦zipファイルをフォルダに保存してから、解凍する2段階必要なのですね。 一括で出来ると思っていたので、それだけでも勉強になりました。 ご教示頂いたコードを試した所、エラーメッセージは出るのですが、フォルダへの保存は成功しておりました。 2段階を念頭において、自分で頑張ってみたいと思います。 無理なときは知恵袋の方々のお力をお借り致します。ありがとうございました。

お礼日時:9/27 19:38