Обновлять имена файлов, если имена файлов содержат указанную c строку, на которую ссылается таблица Excel

Question

Я создал полнофункциональный макрос Outlook, который загружает вложения Outlook в OneDrive указанную папку.

Таким образом, макрос будет обновлять имя файла с доменом электронной почты и месяц / год

например

с исходным именем вложения "Invoice_GBR_Z-GRX_2019_07.pdf"

он становится "comfone.com_08-2019___Invoice_GBR_Z-GRX_2019_07.pdf" после выполнения макроса.

Однако я хотел бы, чтобы макрос также имел возможность сравнивать со таблицей состояния c Excel, называемой таблицей .xls на моем рабочем столе (2 столбца, где столбец A содержит имя домена электронной почты и столбец B, содержащий его соответствующую балансовую единицу), где, если ячейка Excel содержит "comfone.com", тогда к ней добавляется соответствующий ей балансовый код, скажем, 0001 к имени файла

Таким образом, имя файла обновляется до

"0001_comfone.com_08-2019___Invoice_GBR_Z-GRX_2019_07.pdf"

Я борюсь довольно честно говоря, не зная, как ссылаться на таблицу Excel из моего Outlook vba.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim saveName As String
Dim userName As String

Dim sndrEmailAdd As String
Dim sndrEmailRight As String
Dim sndrEmailPreDot As String


' Get the path to your OneDrive folder.
userName = CreateObject("WScript.Network").userName
Debug.Print userName
'strFolderpath = "C:\Users\" & VBA.Environ$("USERNAME") & "\OneDrive - SAP 
SE"
strFolderpath = "C:\Users\" & userName & "\OneDrive - SAP SE"
On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Set the Test folder, change "Test" to any folder name in your OneDrive
strFolderpath = strFolderpath & "\Downloaded Invoices\"


' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection

' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""

If lngCount > 0 Then

    ' We need to use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    For i = lngCount To 1 Step -1

    'Extract text, after @ and before dot, from the email address.
    sndrEmailAdd = objMsg.SenderEmailAddress

    Debug.Print sndrEmailAdd
    'Debug.Print " position of @ sign: " & InStr(sndrEmailAdd, "@")
    'Debug.Print " number of characters right of @ sign: " & 
     Len(sndrEmailAdd) - InStr(sndrEmailAdd, "@")

    'sndrEmailRight = Right(sndrEmailAdd, Len(sndrEmailAdd) - 
    InStr(sndrEmailAdd, "@"))
    sndrEmailRight = Right(sndrEmailAdd, Len(sndrEmailAdd) - 
    InStr(sndrEmailAdd, "@"))
    Debug.Print " text after @ sign: " & sndrEmailRight

    Debug.Print " position of the (first) . period in the remaining text: 
    " & InStr(sndrEmailRight, ".")
    'sndrEmailPreDot = Left(sndrEmailRight, InStr(sndrEmailRight, ".") - 
    1)


        ' Save attachment before deleting from item.
        ' Get the file name.
        strFile = sndrEmailRight & "_" & Format(DateAdd("m", -1, 
        objMsg.ReceivedTime), "mm-yyyy") & "___" & 
        objAttachments.item(i).FileName

        ' Combine with the path to the Temp folder.
        saveName = strFolderpath & strFile

          ' Save the attachment as a file.
         objAttachments.item(i).SaveAsFile saveName

        ' Delete the attachment.
        'objAttachments.item(i).Delete



    Next i

    objMsg.Save

End If
Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Answer 1

См. Пример вызова Excel из Outlook

{ ссылка }

Я обновил ваш код, не забудьте обратиться к библиотеке объектов Microsoft Excel xx.x и обновить путь к папке на одном диске

Пример вашего кода

Option Explicit
Public Sub SaveAttachments()
    Dim Atmts As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strDeletedFiles As String
    Dim saveName As String
    Dim userName As String
    Dim sndrEmailAdd As String
    Dim sndrEmailRight As String
    Dim sndrEmailPreDot As String

    Dim strFolderpath As String
        strFolderpath = "C:\Temp\"

    ' Get the collection of selected objects.
    Dim objSelection As Outlook.Selection
    Set objSelection = Application.ActiveExplorer.Selection

    Dim xlApp As Excel.Application
    Set xlApp = New Excel.Application

    Dim Book As Workbook
    Set Book = xlApp.Workbooks.Open("C:\Temp\Book1.xlsx")

    Dim xlStarted As Boolean
        xlStarted = True

    Dim Sht As Excel.Worksheet
    Set Sht = Book.Sheets("Sheet1")

    Dim Rng As Range

    ' Check each selected item for attachments. If attachments exist,
    ' save them to the strFolderPath folder and strip them from the item.
    Dim objMsg As Outlook.MailItem 'Object
    For Each objMsg In objSelection

        ' This code only strips attachments from mail items.
        ' If objMsg.class=olMail Then
        ' Get the Attachments collection of the item.
        Set Atmts = objMsg.Attachments
        lngCount = Atmts.Count
        Debug.Print lngCount
        strDeletedFiles = ""

        If lngCount > 0 Then

            ' We need to use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.

            For i = lngCount To 1 Step -1

                'Extract text, after @ and before dot, from the email address.
                sndrEmailAdd = objMsg.SenderEmailAddress
                Debug.Print sndrEmailAdd

                sndrEmailRight = Right(sndrEmailAdd, Len( _
                                       sndrEmailAdd) - InStr( _
                                       sndrEmailAdd, "@"))

                Debug.Print sndrEmailRight

                sndrEmailPreDot = Left(sndrEmailRight, _
                                 InStr(sndrEmailRight, ".") - 1)

                Debug.Print sndrEmailPreDot

                For Each Rng In Sht.Range("A1", Sht.Range("A100").End(xlUp))
                    If (Rng.Value) = sndrEmailRight Then
                        sndrEmailPreDot = Rng.Offset(0, 1).Value & "_" & sndrEmailPreDot
                        Debug.Print sndrEmailPreDot
                    End If
                Next

                ' Save attachment before deleting from item.
                ' Get the file name.
                strFile = sndrEmailPreDot & "_" & _
                          Format(DateAdd("m", -1, objMsg.ReceivedTime _
                          ), "mm-yyyy") & "___" & Atmts.Item(i).FileName

                Debug.Print strFile

                ' Combine with the path to the Temp folder.
                saveName = strFolderpath & strFile
                Debug.Print saveName

                ' Save the attachment as a file.
                Atmts.Item(i).SaveAsFile saveName

                ' Delete the attachment.
                'Atmts.item(i).Delete

            Next i

            objMsg.Save

        End If
    Next

    ' Close & SaveChanges
    Book.Close SaveChanges:=True
    If xlStarted Then
        xlApp.Quit
    End If

    Set xlApp = Nothing
    Set Book = Nothing
    Set Sht = Nothing
    Set Rng = Nothing

    Set Atmts = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
End Sub