Question

我每15分钟通过Outlook收到报告。这些报告实际上是Excel附件。我一天只工作8小时;第二天，我通常会有自上一天起每15分钟发布一次的报告。然后我必须单独打开每个报告，然后按标题对它们进行排序。

我知道如何打开并保存每个未读电子邮件附件并将其保存到我的计算机上：

         Sub GetAttachments()
             On Error GoTo GetAttachments_err
             Dim ns As NameSpace
             Dim Inbox As MAPIFolder
             Dim SubFolder As MAPIFolder
             Dim Item As Object
             Dim Atmt As Attachment
             Dim FileName As String
             Dim i As Integer

             Set ns = GetNamespace("MAPI")
             Set Inbox = ns.GetDefaultFolder(olFolderInbox)
             Set Mailbox = Inbox.Parent
             Set SubFolder = Mailbox.Folders("Local Archive")
             i = 0

             'check if there is any mail in the folder'
              If SubFolder.Items.Count = 0 Then
              MsgBox "There are no messages in the folder.", vbInformation, _
                 "Nothing Found"
               Exit Sub
               End If

          'Check each message and save the attachment'
            If SubFolder.Items.Count > 0 Then
              For Each Item In SubFolder.Items
                 If Item.UnRead = True Then
                     For Each Atmt In Item.Attachments
                      FileName = "C:\Users\badana\Desktop\" & Atmt.FileName
                      Atmt.SaveAsFile FileName 'saves each attachment'

                      'this code opens each attachment'
                       Set myShell = CreateObject("WScript.Shell")
                       myShell.Run FileName

                       'this sets the email as read'
                        Item.UnRead = False
                       'updates the counter'
                       i = i + 1

                        Next Atmt
                  End If
              Next Item
            End If

  'Display results

  If i > 0 Then
   MsgBox "I found " & i & " attached files." _
   & vbCrLf & "They are saved on your desktop" _
   & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
   Else
 MsgBox "I didn't find any attached files in your mail.", vbInformation, _
 "Finished!"
 End If

       'Replenish Memory'
        GetAttachments_exit:

       Set Atmt = Nothing
       Set Item = Nothing
       Set ns = Nothing
        Exit Sub

 'function for sorting the excel attachment'


  GetAttachments_err:
  MsgBox "An unexpected error has occurred." _
  & vbCrLf & "Please note and report the following information." _
  & vbCrLf & "Macro Name: GetAttachments" _
  & vbCrLf & "Error Number: " & Err.Number _
  & vbCrLf & "Error Description: " & Err.Description _
  , vbCritical, "Error!"
    Resume GetAttachments_exit
 End Sub

我有按标题排序每个附件的代码：

Sub SortData()
'
' SortData Macro
' sorts data
'

'
  Dim lngLast As Long
  lngLast = Range("A" & Rows.Count).End(xlUp).Row

  Cells.Select
ActiveWorkbook.Worksheets("02APR14").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("02APR14").Sort.SortFields.Add Key:=Range("A2:A" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("02APR14").Sort.SortFields.Add Key:=Range("K2:K" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("02APR14").Sort
    .SetRange Range("A1:L" & lngLast)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
 End Sub

但是，我希望能够在outlook中组合这两个代码，以便我可以将它作为一个宏从outlook运行，它将打开并保存每个附件，并且还可以一次性对它们进行排序。这可能吗？

Answer 1

我已经获取了您的排序数据宏，并在给定文件名时稍微编辑它以打开文件。

您需要使用刚刚保存的附件的文件名在Outlook宏中调用此方法。例如。从您保存的代码中删除这些行：

Set myShell = CreateObject("WScript.Shell")
myShell.Run FileName

并替换为：

openAndSort(FileName)

可以在outlook vba中的同一模块中添加以下代码。它使用早期绑定，因此您需要添加对excel对象库的引用（tools-＆gt; references-＆gt; microsoft excel 14对象库）

Sub openAndSort(filename As String)
'
'
'
'
Dim lngLast As Long

Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Set xl = New Excel.Application
Set wb = xl.Workbooks.Open(filename)
Set sh = wb.Worksheets("02APR14")
xl.Visible = True
  lngLast = sh.Range("A" & Rows.Count).End(xlUp).Row

sh.Sort.SortFields.Clear
sh.Sort.SortFields.Add Key:=sh.Range("A2:A" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
sh.Sort.SortFields.Add Key:=sh.Range("K2:K" & lngLast) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
    .SetRange sh.Range("A1:L" & lngLast)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

wb.Save
wb.Close
Set wb = Nothing
xl.Quit
Set xl = Nothing
End Sub

从Outlook中的宏保存，打开和排序Excel附件

1 个答案: