Question

我在银行工作，我们有很多限制。所以我不能在oulook中使用Developer选项。因此，我只能使用excel VBA做任何事情。

所以这是我的问题，我想自动化“每天都会收到的zip文件，并将其保存在本地驱动器文件夹中，然后自动解压缩并替换昨天的文件（每天应该替换旧的文件）

因为我们不能使用Outlook Developer选项。

我想在Excel工作表中创建一个botton。一旦按下按钮，Outlook中的Zip附件应保存在本地文件夹中，该文件夹应位于我想要的目的地，并且附件应按一下按钮解压缩。

能请我帮忙吗？

我尝试过一些类似的操作，例如使用VBA从oulook保存附件。但没有太大帮助。

Answer 1

我不奇怪银行不希望访问其电子邮件。您可以更改发件人，添加或删除收件人或更改文本。不遗余力地做到这些都是很困难的，但有可能。您不想更改任何内容；您只想自动保存附件，以便技术人员和Outlook都可以允许。

在尝试您需求的更复杂部分之前，让我们检查您的需求是否可行。我不知道您对Excel VBA有多少了解。如果我要您做一些您不了解的事情，请提出问题。

在方便的地方创建启用了宏的工作簿。工作簿的名称无关紧要。

打开工作簿，然后打开VBA编辑器。

单击[工具]，然后单击[参考]。您将获得所有可用库的下拉菜单。向下滚动，直到找到“ Microsoft Outlook nn.0对象库”。 “ nn”标识使用中的Outlook版本，对于您来说，我理解为“ 14”。单击左侧的框，将出现一个勾号。点击[确定]。这将使您可以从Excel访问Outlook。

在项目资源管理器中，您将看到类似以下内容的

：

-  VBAProject (YourNameForWorkbook.xlsm)
  -  Microsoft Excel Objects
       Sheet1 (Sheet1)
       ThisWorkbook

如果任一负号是一个加号，请单击该加号。

单击[ThisWorkbook]。空代码区域将出现在VBA编辑器窗口的右侧。将下面的代码复制到该区域。

在代码中，您会发现以'###开头的行。这些行告诉您必须进行的更改或必须检查的内容。进行必要的更改，然后保存并关闭工作簿。重新打开工作簿。幸运的是，该宏将自动运行，并且默认工作表将报告其已完成的工作。它可能会找到错误的电子邮件并保存了错误的附件。没关系。如果可以保存任何附件，则可以保存所需的附件。

Option Explicit
Sub Workbook_Open()

  '### Replace "C:\DataArea\SO\" with the name of a disc folder on your system
  '    Make sure your folder name ends with \.
  Const DiscFldrDest As String = "C:\DataArea\SO\"
  '### The name of the default worksheet depend on the local language. Replace
  '    "Sheet1" is this is not the default name for you.
  Const WshtOutName As String = "Sheet1"
  ' ### The subject of the email. Correct if I have misunderstood your comment    ' ###
  Const Subject As String = "ISIN List: Financial Sanctions - ISIN screening"     ' ###

  Dim AppOut As Outlook.Application
  Dim Found As Boolean
  Dim InxA As Long
  Dim InxI As Long
  Dim OutFldrInbox As Outlook.Folder
  Dim RowNext As Long
  Dim WshtOut As Worksheet

  Set AppOut = CreateObject("Outlook.Application")

  With AppOut
    With .Session
      Set OutFldrInbox = .GetDefaultFolder(olFolderInbox)
    End With
  End With

  Set WshtOut = Worksheets(WshtOutName)
  RowNext = WshtOut.Cells(Rows.Count, "A").End(xlUp).Row + 1

  '### Change if you prefer different date or time formats
  WshtOut.Cells(RowNext, "A").Value = "Macro activated at " & _
                                      Format(Now(), "h:mm") & " on " & _
                                      Format(Now(), "d mmm yy")
  RowNext = RowNext + 1

  '### GetDefaultFolder is not much use on my system because I have two
  '    email addresses, each with their own Inbox, neither of which is
  '    the default Inbox.  Probably you only have one work email address
  '    which is the default for you.  To check, the following statement
  '    outputs the name of the default Inbox's mailbox.  Tell me if it is
  '    not the mail box you want.
  WshtOut.Cells(RowNext, "A").Value = Space(6) & "Inbox accessed"
  WshtOut.Cells(RowNext, "B").Value = OutFldrInbox.Parent.Name
  RowNext = RowNext + 1

  Found = False

  With OutFldrInbox
    For InxI = .Items.Count To 1 Step -1
      With .Items(InxI)
        If .Subject = Subject And .Attachments.Count > 0 Then                            '###
          WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved from email"   '###
          WshtOut.Cells(RowNext, "B").Value = "With subject"
          WshtOut.Cells(RowNext, "C").Value = .Subject
          RowNext = RowNext + 1
          WshtOut.Cells(RowNext, "B").Value = "Received"
          'WshtOut.Cells(RowNext, "C").Value = .ReceivedTime
          WshtOut.Cells(RowNext, "C").Value = Format(.ReceivedTime, "\a\t h:mm \o\n d mmm yy")
          'WshtOut.Cells(RowNext, "C").NumberFormat = "at h:mm on d mmm yy"
          RowNext = RowNext + 1
          WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved"             '###
          For InxA = 1 To .Attachments.Count                                            '###
            If UCase(Right$(.Attachments(InxA), 4)) = ".ZIP" Then                       '###
              WshtOut.Cells(RowNext, "B").Value = .Attachments(InxA).Filename           '###
              .Attachments(1).SaveAsFile DiscFldrDest & .Attachments(1).Filename        '###
              Found = True                                                              '###
              Exit For                                                                  '###
            End If                                                                      '###
          Next                                                                          '###
        End If
      End With
    Next

    With WshtOut
      If Not Found Then
        .Cells(RowNext, "B").Value = "No email with correct subject and a ZIP attachment found"
        RowNext = RowNext + 1
      End If
      .Columns.AutoFit
      .Cells(RowNext, "A").Select
    End With

  End With

End Sub

从Outlook 2010保存zip附件并保存在内部驱动器（文件夹）中

1 个答案: