在我的工作中，Outlook 中的 vba 处于关闭状态，因此多年来我一直使用存储 outlook 附件的 Excel vba。但是当我尝试在 Windows 10 / Office 365 x64 / OneDrive 中使用它时，它不起作用。事实上，我什至无法在添加代码后保存 excel 文件（这该死的..）。它清楚地对代码中的某些内容做出反应。下面列出了整个代码，在顶部我添加了一个部分，其中包含我发现的代码，这就是我的 excel 文件无法保存的原因（当我添加此位时，文件将无法保存）。希望任何人都可以调整代码以保存在我的 excel 文件中，并且当我在 365/x64/OneDrive 中运行它时它会工作，因为这显然超出了我的能力范围......
防止保存 excel 文件的代码：
#If VBA7 Then
' The window handle of Outlook.
Private lHwnd As LongPtr
' /* API declarations. */
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
' The window handle of Outlook.
Private lHwnd As Long
' /* API declarations. */
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
完整代码：
Option Explicit
' *****************
' For Outlook 2010. Tested ok on Outlook 365 x32 as well!
' *****************
#If VBA7 Then
' The window handle of Outlook.
Private lHwnd As LongPtr
' /* API declarations. */
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
' The window handle of Outlook.
Private lHwnd As Long
' /* API declarations. */
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260
' ######################################################
' Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO As Object ' Computer's file system object.
Dim objShell As Object ' Windows Shell application object.
Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
Dim objItem As Object ' A specific member of a Collection object either by position or by key.
Dim selItems As Selection ' A collection of Outlook item objects in a folder.
Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
Dim strAtmtPath As String ' The full saving path of the attachment.
Dim strAtmtFullName As String ' The full name of an attachment.
Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
Dim intDotPosition As Integer ' The dot position in an attachment name.
Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
Dim strFolderPath As String ' The selected folder path.
Dim blnIsEnd As Boolean ' End all code execution.
Dim blnIsSave As Boolean ' Consider if it is need to save.
blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
On Error Resume Next
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
' Get the handle of Outlook window.
lHwnd = FindWindow(olAppCLSN, vbNullString)
If lHwnd <> 0 Then
' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objShell.BrowseForFolder(lHwnd, "Folder to store attachments in:", _
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, "I:\My documents\OLAttachments")
' /* Failed to create the Shell application. */
If Err.Number <> 0 Then
MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
Err.Description & ".", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
If objFolder Is Nothing Then
strFolderPath = ""
blnIsEnd = True
GoTo PROC_EXIT
Else
strFolderPath = CGPath(objFolder.Self.Path)
' /* Go through each item in the selection. */
For Each objItem In selItems
lCountEachItem = objItem.Attachments.Count
' /* If the current item contains attachments. */
If lCountEachItem > 0 Then
Set atmts = objItem.Attachments
' /* Go through each attachment in the current item. */
For Each atmt In atmts
' Get the full name of the current attachment.
strAtmtFullName = atmt.Filename
' Find the dot postion in atmtFullName.
intDotPosition = InStrRev(strAtmtFullName, ".")
' Get the name.
strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
' Get the file extension.
strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
' Get the full saving path of the current attachment.
strAtmtPath = strFolderPath & atmt.Filename
' /* If the length of the saving path is not larger than 260 characters.*/
If Len(strAtmtPath) <= MAX_PATH Then
' True: This attachment can be saved.
blnIsSave = True
' /* Loop until getting the file name which does not exist in the folder. */
Do While objFSO.FileExists(strAtmtPath)
strAtmtNameTemp = strAtmtName(0) & _
Format(Now, "_mmddhhmmss") & _
Format(Timer * 1000 Mod 1000, "000")
strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
' /* If the length of the saving path is over 260 characters.*/
If Len(strAtmtPath) > MAX_PATH Then
lCountEachItem = lCountEachItem - 1
' False: This attachment cannot be saved.
blnIsSave = False
Exit Do
End If
Loop
' /* Save the current attachment if it is a valid file name. */
If blnIsSave Then atmt.SaveAsFile strAtmtPath
Else
lCountEachItem = lCountEachItem - 1
End If
Next
End If
' Count the number of attachments in all Outlook items.
lCountAllItems = lCountAllItems + lCountEachItem
Next
End If
Else
MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
Else
MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
' /* Release memory. */
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (atmt Is Nothing) Then Set atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing
' /* End all code execution if the value of blnIsEnd is True. */
If blnIsEnd Then End
End Function
' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function
' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExcelSaveOutlookAttachments()
Dim lNum As Long
lNum = SaveAttachmentsFromSelection
If lNum > 0 Then
MsgBox CStr(lNum) & " attachments was saved without any errors.", vbInformation, "Excel Message"
Else
MsgBox "There are no attachments to save in selected mails!", vbInformation, "Excel Message"
End If
End Sub
当我在 365/x64/OneDrive 中运行它时
SaveAsFile方法将附件保存到指定路径，该方法不了解OneDrive，旨在处理本地文件系统。您可以将附件保存到磁盘上的任何本地文件夹，然后将它们上传到 OneDrive 存储。
在查看您的代码后，我发现了几个方面：
SaveAsFile方法可能会覆盖具有相同
FileNameatmt.SaveAsFile strAtmtPath
为防止这种情况发生，您需要在文件名中添加任何 ID。例如，您可以考虑使用当前时间或仅使用
RecievedTimeMailItemOutlook 文件夹可能包含不同种类的项目，因此
SelectionMessageClass以下代码只有在 Outlook VBA 中运行才有意义：
Set selItems = ActiveExplorer.Selection
否则，您需要创建一个新的 Outlook
ApplicationApplication最后，您可能会发现Office 中的 VBA 入门文章很有帮助。