SavetheattachmentNew

标签：sub   err   filename   olap   sele   rect   use   var   name   

Public Sub SavetheattachmentNew(Item As Outlook.MailItem)

Dim olApp As New Outlook.Application
Dim nmsName As Outlook.NameSpace
Dim vItem As Object
Set nmsName = olApp.GetNamespace("MAPI")
Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
Dim afname, afnameT

dd = "C:\Users\yliu513\attachment"
If Dir(dd, vbDirectory) = "" Then MkDir dd
‘若无文件夹则新建该文件夹

Dim olAtt As Attachment
Dim I As Integer

If Item.Attachments.Count > 0 Then
For I = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(I)

‘对每一封带附件的邮件
fn = "C:\Users\yliu513\attachment\" & olAtt.fileName
‘fn为路径+附件名
n = 1
Do Until Dir(fn) = ""
‘如果为空，说明该路径下没有该文件
fn = "C:\Users\yliu513\attachment\ " & n & "_" & olAtt.fileName
‘有该文件名则重命名前面加数字
n = n + 1
Loop

olAtt.SaveAsFile fn

afname = olAtt.fileName
afnameT = Right(afname, Len(afname) - InStrRev(afname, "."))

If StrComp("ZIP", afnameT, 1) = 0 Then
MsgBox "StrComp = 0"
Unzip (fn)
End If

‘附件保存中
Next
End If
Set olAtt = Nothing

Set nmsName = Nothing

End Sub

Sub Unzip(zipPath)
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
‘Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
‘If Not (Fname = False) Then
‘新文件夹的上级文件夹.
‘你也可以支持指定路径
‘DefPath = "C:\Users\yliu513\attachment"
DefPath = "U:\attachment"
‘DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

‘创建文件夹名称
‘strDate = Format(Now, " dd-mm-yy h-mm-ss")
‘FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

strDate = Format(Now, "dd-mm-yy")
FileNameFolder = DefPath & strDate & "\"
‘创建名为 DefPath 的普通文件夹
If Dir(FileNameFolder, vbDirectory) = "" Then MkDir FileNameFolder
‘提取所有文件到此创建的文件夹
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(zipPath).Items
‘假如你只需要提取某一个文件，可以如下:
‘oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "文件已经解压到: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
‘删除临时文件
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
‘End If
End Sub

SavetheattachmentNew

标签：sub   err   filename   olap   sele   rect   use   var   name   

原文地址：https://www.cnblogs.com/kinyulau/p/14606744.html