将 Outlook 的选定电子邮件保存在 Windows 文件夹中的宏

问题描述

限时删除！！

我正在尝试将 Outlook 电子邮件保存到 windows 文件夹，但我拥有的宏无法正常工作，在每封电子邮件保存它打开浏览窗口，

I am trying to save outlook emails to windows folder, but the macro which i had is not working properly,at each email save it opens browse window,

它应该一次将所有选定的邮件保存到浏览文件夹中

it should save all the selected mails to a browse folder at a time

Option Explicit

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

 On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0

 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = ""
            If Not Left(BrowseForFolder, 1) = "" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function

Invalid:
 BrowseForFolder = False
End Function


Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath, strFolderpath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"



  strFolderpath = BrowseForFolder("D:	estmails")
  sPath = strFolderpath & ""
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG

  End If
  Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

推荐答案

将 BrowseForFolder 移到循环之外

Move BrowseForFolder outside of the loop

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath, strFolderpath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String

    enviro = CStr(Environ("USERPROFILE"))

    strFolderpath = BrowseForFolder("D:	estmails")
    sPath = strFolderpath & ""

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "-"
            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
              vbUseSystem) & Format(dtDate, "-hhnnss", _
              vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
            Debug.Print sPath & sName
            oMail.SaveAs sPath & sName, olMSG
         End If
    Next
End Sub

这篇关于将 Outlook 的选定电子邮件保存在 Windows 文件夹中的宏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！

1403页，肝出来的..