Макрос сохраняет один файл с разными именами вместо каждого файла

Question

Итак, у меня есть макрос, который создает каталог, переименовывает вложение и сохраняет его работающим по правилу при поступлении сообщений в Outlook.Проблема заключается в том, что приходят 3 электронных письма с адресами

123 на главной улице, город 1
456 на главной улице, город 2
789 на главной улице 3

Он сохранит их в соответствующих папках и будет называть файл соответствующим образом на основе адреса, но когда вы входите в файлы, все они имеют одинаковую информацию, поэтому он сохраняет вложение для адреса 456 main st как и все 3 имени файла.

Вот мой код:

Private Function CreateDir(FldrPath As String)
    Dim Elm As Variant
    Dim CheckPath As String

    CheckPath = ""
    For Each Elm In Split(FldrPath, "\")
        CheckPath = CheckPath & Elm & "\"

        If Len(Dir(CheckPath, vbDirectory)) = 0 Then
            MkDir CheckPath
            Debug.Print CheckPath & " Folder Created"
        End If

        Debug.Print CheckPath & " Folder Exist"
    Next
End Function

Sub SaveEagleView(itm As Outlook.MailItem)
    Dim strSubject As String, strExt As String
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim NextFriday As Date
    Dim sFileName As String
    Dim varAddress As Variant
    Dim City As Variant
    Dim fdObj As Object
    Dim JobArea As String
    Dim JobCity As Variant
    Dim myPath As String
    Dim myFinalPath As String
    Dim objMsg As MailItem
    Dim sFileExt As String

    Set objMsg = Application.CreateItem(olMailItem)

    Dim enviro As String
    NextFriday = Date + 8 - Weekday(Date, vbFriday)
    Set myfolder = Outlook.ActiveExplorer.CurrentFolder
    Set fdObj = CreateObject("Scripting.FileSystemObject")

    'Loop through emails in folder
    For i = 1 To myfolder.Items.Count
        Set myitem = myfolder.Items(i)
        msgtext = myitem.Body

        'Search for Specific Text
        delimitedMessage = Right$(msgtext, Len(msgtext) - InStr(1, msgtext, "Address: ") - 8)
        varAddress = Split(delimitedMessage, ",")

        'Assign the job address from email to variable
        sFileName = varAddress(0)
        JobCity = RTrim(LTrim(varAddress(1)))


        'Define office area based on job city

        If JobCity = "Panama City" Or JobCity = "Mexico Beach" Or JobCity = "Panama City Beach" Or JobCity = "Lynn Haven" Or JobCity = "Port Saint Joe" Then
            JobArea = "Panama"
        ElseIf JobCity = "Daytona Beach" Or JobCity = "Port Orange" Or JobCity = "Deltona" Or JobCity = "Ormond Beach" Or JobCity = "Deland" Then
            JobArea = "Daytona"
        ElseIf JobCity = "Orlando" Then
            JobArea = "Orlando"
        ElseIf JobCity = "Jacksonville" Or JobCity = "Jacksonville Beach" Then
            JobArea = "Jacksonville"
        Else
            JobArea = JobCity
        End If

        For Each objAtt In itm.Attachments
            saveFolder = "C:\Users\admin\OneDrive\Documents\EagleView\" & Format$(NextFriday, "yyyy-mm-dd") & "\" & JobArea & "\"

            CreateDir saveFolder
            If Right(objAtt.FileName, 3) = "PDF" Then
                sFileExt = ".pdf"
                File = saveFolder & sFileName & sFileExt
                objAtt.SaveAsFile File
            End If

            '            With objMsg
            '               .To = "Careers@Email.com"
            '              .CC = "CustomerService@Email.com"
            '             .Subject = "New EagleView Needs Uploaded"
            '            .BodyFormat = olFormatPlain
            '           .Body = "A new EagleView has been received for the " & JobArea & " office. The file name is " & sFileName & " and needs to be uploaded. Thanks!"
            '          .Send
            '     End With

            '    Set objMsg = Nothing

        Next
    Next

    Set objAtt = Nothing
End Sub

Код для создания электронного письма закомментирован, потому что он не работает, но я бы предпочел убедиться, чтоСохранение файла работает правильно, прежде чем двигаться дальше, пытаясь заставить его работать.

Спасибо за всю вашу помощь заранее!

Отредактировано, чтобы предоставить больше информации:

Итак,в электронных письмах это будет содержаться в теле:

• Адрес: 123 main St, City, State 12345-1234

Способ написания кода должен, и кажется,, он должен перебирать электронные письма, к которым применяется правило, иизвлеките уличный адрес и примените это значение к sFileName, и эта часть работает должным образом, поскольку она проходит цикл, и получает правильное имя файла для каждого письма, которое приходит;тем не менее, он просто применяет это имя к одному и тому же файлу снова и снова.

Действующее правило гласит:

Примените это правило после того, как сообщение поступит
от admin @email.com
и с EagleView в теме
и с $ в теле
и только на этом компьютере
переместите его на
и запустите Project1.SaveEagleView

Answer 1

Я не тестировал этот код, это урезанная версия, поэтому все, что он делает, это сохраняет файл, и я предполагаю, что электронная почта передается в процедуру правильно.

Первая проблема, которую я вижу, состоит в том, что если электронное письмо содержит более одного вложения в формате PDF, оно будет сохранено в одной папке с одинаковым именем (поэтому первое будет перезаписано).

Sub SaveEagleView(itm As MailItem)

    Const SAVE_PATH As String = "C:\Users\admin\OneDrive\Documents\EagleView\"

    Dim msgText As String
    Dim delimitedMessage As String
    Dim varAddress As Variant
    Dim sFileName As String
    Dim JobCity As String
    Dim JobArea As String
    Dim objAtt As Attachment
    Dim NextFriday As String
    Dim Save_Folder As String

    NextFriday = Format(Date + 8 - Weekday(Date, vbFriday), "yyyy-mm-dd")

    msgText = itm.Body
    delimitedMessage = Right$(msgText, Len(msgText) - InStr(1, msgText, "Address: ") - 8)
    varAddress = Split(delimitedMessage, ",")
    sFileName = varAddress(0)
    JobCity = Trim(varAddress(1)) 'TRIM does both LTRIM & RTRIM.

    Select Case JobCity
        Case "Panama City", "Mexico Beach", "Panama City Beach", "Lynn Haven", "Port Saint Joe"
            JobArea = "Panama"
        Case "Daytona Beach", "Port Orange", "Deltona", "Ormand Beach", "Deland"
            JobArea = "Daytona"
        Case "Jacksonville", "Jacksonville Beach"
            JobArea = "Jacksonville"
        Case Else
            JobArea = JobCity 'Orlando would fall in here to.
    End Select

    Save_Folder = SAVE_PATH & NextFriday & "\" & JobArea & "\"
    If Len(Dir(Save_Folder)) = 0 Then
        MkDir Save_Folder
    End If

    If itm.Attachments > 0 Then
        For Each objAtt In itm.Attachments
            If GetExt(objAtt.FileName) = "PDF" Then
                objAtt.SaveAsFile Save_Folder & sFileName & ".pdf"
            End If
        Next objAtt
    End If

End Sub

Public Function GetExt(FileName As String) As String
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    GetExt = oFSO.GetExtensionName(FileName)
    Set oFSO = Nothing
End Function  

Также очень важно -

• Выбрать Tools ~ Options
• На вкладке Editor установите флажок Require Variable Declaration.

Это поместит Option Explicit вверху каждого нового модуля и заставит вас объявлять каждую переменную перед использованием.

В вашем коде 6 необъявленных переменных.Неправильное написание переменной приведет к тому, что будет создана новая, а старая сохранит старое или нулевое значение, что приведет к дальнейшему беспорядку, возможно, без сообщения об ошибке.

Редактировать:
Я не уверен, как вы заставляете скрипт работать с правилом, так как ему передан аргумент.
Как я мог бысделать это, чтобы просмотреть папку и запустить скрипт, когда электронное письмо перемещается в эту папку (вручную или по правилу).

Добавьте этот код в ThisOutlookSession, и он вызовет процедуру SaveEagleView, передав ей электронное письмо, которое было перемещено в папку.
Возможно, вам придется изменить MailItem в SaveEagleViewимя процедуры до Object.
Первая строка должна быть в самом верху модуля - перед любыми процедурами.

Dim WithEvents EagleView As Items

Private Sub Application_Startup()

    Dim ns As Outlook.NameSpace

    Set ns = Application.GetNamespace("MAPI")

    'Rename to correct account/folder.
    With ns.Folders.Item("EagleView").Folders.Item("Inbox")
        Set EagleView = .Folders.Item("EagleView").Items
    End With

End Sub

Private Sub EagleView_ItemAdd(ByVal Item As Object)
    SaveEagleView Item
End Sub

Private Sub Application_Quit()

    Set EagleView = Nothing

End Sub