Question

我编译的宏运行良好，但随后我进一步改进了＃34;它由于某种原因在第一次成功循环后停止。宏将附件从电子邮件保存到NAS上的文件夹。第二次运行它在SaveAsFile行停止。感谢您的任何意见。

    Public Sub SaveAttsToNAS(MItem As Outlook.MailItem)
    Dim oAttachment As Outlook.Attachment ' A document or link to a document contained in an Outlook item.
    Dim sSaveFolder As String
    Dim sPath As String
    Dim regDate As Date
    Dim strDate As String
    Dim objFSO, strFolder

    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 intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim strAtmtFullName     As String       ' The full name of an attachment.

    sSaveFolder = "P:\"
    regDate = MItem.ReceivedTime
    strDate = Format(regDate, "yyyymmdd")
    sPath = sSaveFolder & strDate

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not objFSO.FolderExists(sPath) Then
       objFSO.CreateFolder (sPath)
    End If

    For Each oAttachment In MItem.Attachments
        ' Get the full name of the current attachment.
      strAtmtFullName = oAttachment.FileName
      intDotPosition = InStrRev(strAtmtFullName, ".")
        ' Get the file extension.
      strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
        ' Exclude Gifs and save the current attachment.
      If strAtmtName(1) <> "gif" Then
        oAttachment.SaveAsFile sPath  & "\" & strAtmtFullName
      End If

    Next
    End Sub

Answer 1

我的错误不一致，你可以等一下。

Public Sub SaveAttsToNAS(MItem As Outlook.MailItem)

....

Dim i As Long
Dim numTries As Long

....

    ' Exclude Gifs and save the current attachment.
    If strAtmtName(1) <> "gif" Then

        i = 0
        numTries = 100

retryNAS:
        On Error GoTo slowNAS
        oAttachment.SaveAsFile sPath & "\" & strAtmtFullName
        Debug.Print "Attachment path and name: " & sPath & "\" & strAtmtFullName
        On Error GoTo 0

    End If

Next

Exiting:
Exit Sub

slowNAS:

i = i + 1
Debug.Print i & " Err.number: " & Err.number & " - Err.Description: " & Err.Description

If i >= numTries Then

    If MsgBox("Tried " & numTries & " times. Again?", vbYesNo) = vbYes Then
        i = 0
        Resume retryNAS
    Else
        Resume Exiting
    End If

Else
    Resume retryNAS
End If

End Sub

Outlook宏只保存了一个附加文件并停止

1 个答案: