Outlookにてzipファイルをマクロでリネームするには？

Outlookマクロにて、下記を参考に添付ファイルをzipファイルに圧縮する事ができたのですが、
https://outlooklab.wordpress.com/2007/11/17/%E6% …

例）添付ファイル.xlsx　⇒　ファイル名.xlsx.zip
となります。　これを本当はファイル名.zipにしたいです。
それを更にファイル名.zzzと拡張子を変更したりリネームをしたいのですが、何を追記すれば
このような結果になるのでしょうか？

詳しい方、ご教授のほどよろしくお願いいたします。

質問者からの補足コメント

• 

  ご回答ありがとうございます。私の質問内容が悪かったと思います。
  この記述で確かに、
  添付ファイル.xlsx　⇒　ファイル名.xlsx.zip
  　が、添付ファイル.xlsx　⇒　ファイル名.zipとなる事を確認しました。
  
  実際には、"添付ファイル.xlsx"を圧縮zipファイルにしたいのですが、
  圧縮ファイル名が"添付ファイル.xlsx.zip"となってしまうのです。
  
  それを解消したく、圧縮したファイル名を、添付ファイル.zip（拡張子ファイル名なし）
  にしたく、出来上がった圧縮ファイルの”添付ファイル.zip”を添付ファイル.zzzと拡張子変換を
  させたいのです。（リネーム）
  申し訳ございませんが、この内容でご教授頂けますでしょうか？

  No.1の回答に寄せられた補足コメントです。 補足日時：2016/04/29 00:50

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2016/04/29 04:50

>実際には、"添付ファイル.xlsx"を圧縮zipファイルにしたいのですが、

それは、.xlsx ファイルをすでにzipファイルとし圧縮されていますから、本来、そのようなことは不要です。.zipの拡張子を、.xlsxなどに変えているに過ぎません。

もし、アーカイブにするなら、専用アプリで圧縮やアーカイブにしたほうがよいです。(私自身が作ったZIP圧縮マクロは、まだ残っているはずです）

>添付ファイル.zip”を添付ファイル.zzzと拡張子変換を
>させたいのです。（リネーム）

今回、ご要望では作りましたが、絶対に、乱用するようなことは、相手の人に迷惑が掛かりますから、必ず、お互いが了解の元で行ってください。

拡張子を任意に変えるのは、よほど気をつけないとトラブルになりますから、注意願います。私などは、そのために、バイナリエディタを使うのです。

拡張子は、●の部分で変更する
---------------------------------
'
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' ZIP 圧縮を行う VBA マクロ(変形版）
Public Sub ZipCompressAttachment()
　　　　Dim objShell ' As Shell32.Shell
　　　　Dim objFS ' As Scripting.FileSystemObject
　　　　Dim strTemp As String
　　　　Dim fldTemp ' As Scripting.Folder
　　　　Dim objItem　　As MailItem
　　　　Dim i As Integer
　　　　Dim objAttach As Attachment
　　　　Dim strAttach 'As String
　　　　Dim strEmptyZip 'As String
　　　　Dim strZipFile 'As String
　　　　Dim stmZipFile ' As Scripting.TextStream
　　　　Dim fldZip ' As Shell32.Folder
　　　　Dim strBaseName As String
　　　　Dim objFile As Object
　　　　Dim myPath As String
　　　　Const EXT As String = ".zip"　'●
　　　　 If Left$(EXT, 1) <> "." Then MsgBox "必ず、拡張子には　.(コンマを入れてください）", vbExclamation: Exit Sub
　　　　' SHELL オブジェクトと FileSystemObject オブジェクトを生成
　　　　Set objFS = CreateObject("Scripting.FileSystemObject")
　　　　Set objShell = CreateObject("Shell.Application")
　　　　' 作業フォルダの作成 (%TEMP% で指定される一時フォルダの下にランダムな名前のフォルダを作成)
　　　　strTemp = objFS.GetSpecialFolder(2) & "\" & objFS.GetTempName()
　　　　Set fldTemp = objFS.CreateFolder(strTemp)
　　　　' 作成中のアイテムを取得
　　　　If ActiveInspector Is Nothing Then
　　　　　　 MsgBox "階層のトップに該当するメッセージがありません。", vbExclamation
　　　　　　 Exit Sub
　　　　End If
　　　　Set objItem = ActiveInspector.CurrentItem
　　　　' 作成中のアイテムを一旦保存
　　　　objItem.Save
　　　　' 添付ファイルの一つ一つについてチェック
　　　　For i = objItem.Attachments.Count To 1 Step -1
　　　　　　　　Set objAttach = objItem.Attachments.Item(i)
　　　　　　　　' 既に ZIP で圧縮済みなら圧縮しない
　　　　　　　　If Not objAttach.FileName Like "*.zip" And objAttach.Type = olByValue Then
　　　　　　　　　　 ' 作業フォルダに作成するファイルの名前を取得
　　　　　　　　　　　　strBaseName = objFS.getBaseName(objAttach.FileName)
　　　　　　　　　　　　strAttach = strTemp & "\" & objAttach.FileName
　　　　　　　　　　　　strZipFile = strAttach & ".zip"
　　　　　　　　　　　　' 作業フォルダに添付ファイルを保存
　　　　　　　　　　　　objAttach.SaveAsFile strAttach
　　　　　　　　　　　　' 空の ZIP ファイルを作成
　　　　　　　　　　　　strEmptyZip = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(20, 0)
　　　　　　　　　　　　Set stmZipFile = objFS.CreateTextFile(strZipFile, True, False)
　　　　　　　　　　　　stmZipFile.Write strEmptyZip
　　　　　　　　　　　　stmZipFile.Close
　　　　　　　　　　　　' ZIP ファイルをフォルダとして取得し、添付ファイルをコピー
　　　　　　　　　　　　Set fldZip = objShell.NameSpace(strZipFile)
　　　　　　　　　　　　fldZip.CopyHere strAttach, 16
　　　　　　　　　　　　' ZIP ファイルの圧縮は非同期で行われるため、コピーが終わったかどうかをファイルがオープンできるかどうかで判断
　　　　　　　　　　　　On Error Resume Next
　　　　　　　　　　　　Do
　　　　　　　　　　　　　　　　DoEvents
　　　　　　　　　　　　　　　　Sleep 5000
　　　　　　　　　　　　　　　　Err.Clear
　　　　　　　　　　　　　　　　Set stmZipFile = objFS.OpenTextFile(strZipFile)
　　　　　　　　　　　　Loop While Err.Number <> 0
　　　　　　　　　　　　stmZipFile.Close
　　　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　　　' 添付ファイルと ZIP ファイルを入れ替え
　　　　　　　　　　　　If Dir(strZipFile) <> "" Then
　　　　　　　　　　　　　　Set objFile = objFS.GetFile(strZipFile)
　　　　　　　　　　　　　　 myPath = objFS.GetParentFolderName(strZipFile)
　　　　　　　　　　　　　　 strZipFile = myPath & "\" & strBaseName & EXT
　　　　　　　　　　　　　　 objFile.Name = strBaseName & EXT
　　　　　　　　　　　　　　 Else
　　　　　　　　　　　　　　　　MsgBox "失敗しました", vbExclamation
　　　　　　　　　　　　　　　　Exit Sub
　　　　　　　　　　　　End If
　　　　　　　　　　　　objAttach.Delete
　　　　　　　　　　　　If objAttach.Position = 0 Then
　　　　　　　　　　　　　　　　objItem.Attachments.Add strZipFile, olByValue, , objAttach.DisplayName
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　objItem.Attachments.Add strZipFile, olByValue, objAttach.Position, objAttach.DisplayName
　　　　　　　　　　　　End If
　　　　　　　　　　　　' 作業フォルダのファイルを削除
　　　　　　　　　　　　On Error Resume Next
　　　　　　　　　　　　objFS.DeleteFile strAttach
　　　　　　　　　　　　objFS.DeleteFile strZipFile
　　　　　　　　　　　　On Error GoTo 0
　　　　　　　　End If
　　　　Next
　　　　' 作業フォルダを削除
　　　　fldTemp.Delete
End Sub

この回答へのお礼

できました。ありがとうございました！

お礼日時：2016/05/01 22:59

No.1 回答者： WindFaller 回答日時： 2016/04/28 12:44

>例）添付ファイル.xlsx　⇒　ファイル名.xlsx.zip

>となります。　これを本当はファイル名.zipにしたいです。

これですと、開けなくなりますね。
つまり、Excelファイルをソース閲覧可能にするということですね。

>ファイル名.zip
は、確かに、zipファイルですが、そのサイトの趣旨とは大幅に異なる内容だということはお気づきですか？送信する側も受信する側も、了解の上で行ってください。なお、以下は複数のファイルを試してみたわけではありません。


'//
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'拡張子を変える VBA マクロ
Public Sub ZipCompressAttachment()
　　　　Dim objShell ' As Shell32.Shell
　　　　Dim objFS ' As Scripting.FileSystemObject
　　　　Dim strTemp As String
　　　　Dim fldTemp ' As Scripting.Folder
　　　　Dim objItem ' As MailItem
　　　　Dim i As Integer
　　　　Dim objAttach As Attachment
　　　　Dim strAttach 'As String
　　　　Dim strEmptyZip 'As String
　　　　Dim strZipFile 'As String
　　　　Dim stmZipFile ' As Scripting.TextStream
　　　　Dim fldZip ' As Shell32.Folder
　　　　Dim dfn As String
　　　　Const EXT As String = ".zip"　　'必ず点を入れること
　　　　If Left$(EXT, 1) <> "." Then MsgBox "必ず、拡張子には　.(コンマを入れてください）", vbExclamation: Exit Sub
　　　　' SHELL オブジェクトと FileSystemObject オブジェクトを生成
　　　　Set objFS = CreateObject("Scripting.FileSystemObject")
　　　　Set objShell = CreateObject("Shell.Application")
　　　　' 作業フォルダの作成 (%TEMP% で指定される一時フォルダの下にランダムな名前のフォルダを作成)
　　　　strTemp = objFS.GetSpecialFolder(2) & "\" & objFS.GetTempName()
　　　　Set fldTemp = objFS.CreateFolder(strTemp)
　　　　' 作成中のアイテムを取得
　　　　Set objItem = ActiveInspector.CurrentItem
　　　　' 作成中のアイテムを一旦保存
　　　　objItem.Save
　　　　' 添付ファイルの一つ一つについてチェック
　　　　For i = objItem.Attachments.Count To 1 Step -1
　　　　　　　　Set objAttach = objItem.Attachments.Item(i)
　　　　　　　　If Not objAttach.FileName Like "*.zip" And objAttach.Type = olByValue Then
　　　　　　　　　　　　' 作業フォルダに作成するファイルの名前を取得
　　　　　　　　　　　　strAttach = strTemp & "\" & objAttach.FileName
　　　　　　　　　　　　strZipFile = Mid(strAttach, 1, InStrRev(strAttach, ".") - 1) & EXT
　　　　　　　　　　　　' 作業フォルダに添付ファイルを保存
　　　　　　　　　　　　objAttach.SaveAsFile strZipFile
　　　　　　　　　　　　objAttach.Delete
　　　　　　　　　　　　dfn = Mid(strZipFile, InStrRev(strZipFile, "\") + 1)
　　　　　　　　　　　　If objAttach.Position = 0 Then
　　　　　　　　　　　　　　　　objItem.Attachments.Add strZipFile, olByValue, , dfn
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　objItem.Attachments.Add strZipFile, olByValue, objAttach.Position, dfn
　　　　　　　　　　　　End If
　　　　　　　　　　　　' 作業フォルダのファイルを削除
　　　　　　　　　　　　objFS.DeleteFile strZipFile
　　　　　　　　End If
　　　　Next
　　　　' 作業フォルダを削除
　　　　fldTemp.Delete
End Sub
'///