Как да свържа Outlook с Excel?

Question

Здравейте,

Опитвам се да свържа outlook с еxcel във VBA.

Всеки ден получавам много имейли, съдържащи прикачен текстови файл, заедно с други прикачени файлове. Трябва ръчно да изтегля всеки един текстови файл и след това да го обработя в Ексел. Макрото, което се опитвам да напиша, трябва да може да отваря текстовия файл и да пейства съдържанието му в Ексел. Искам да мога да пусна кода в Ексел и програмата сама да ми зарежда прикачения текстови файл от имейла в Outlook в екселския файл, без да се налагам всеки път да отварям текстовия файл в Notepad, да го, маркирам, копирам и пействам в Ексел.

Въпроса ми е как да свържа Ексел с Outlook и да изтегля успешно файла? Благодаря предварително!

Това, което успях да направя сам:

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim strFile As String
For Each objMsg In Selection
strFile = objAttachments.Item.FileName
objAttachments.Item.SaveAsFile strFile

Answer 1

Здравей,

За да може да ползваш Outllok през Excel vba, трябва да добавиш библиотеката Microsoft Outlook Object Library (от Tools - References).

Този код тегли всички прикачени файлове и отваря най-новия текстови файл. Ако е необходимо, можеш да го промениш според твоите нужди, за да тегли само определен файл, който ти трябва:

Public Sub SaveAttachments()
'Set refernce to Microsoft Outlook Object Library
Application.ScreenUpdating = False
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
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 strExePath As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))

    ' Get the path to your folder
    strFolderpath = enviro
    
    On Error Resume Next
    'Connect to MS Outlook
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection

    ' Set the Attachment folder. (Create OLAttachments folder on your Desktop)

    strFolderpath = strFolderpath & "\Desktop\OLAttachments\"
   
    'Get the attachment
    For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    
    lngCount = objAttachments.Count
      If lngCount > 0 Then
        For i = lngCount To 1 Step -1
         'Save the file to the Attachment folder
         strFile = objAttachments.Item(i).FileName
         strFile = strFolderpath & strFile
         
         objAttachments.Item(i).SaveAsFile strFile
    Next
    End If
    Next   
    Call OpenNewestTextFile

ExitSub:

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

Sub OpenNewestTextFile()

    Dim MyPath As String

    Dim MyFile As String

    Dim LatestFile As String

    Dim LatestDate As Date

    Dim LMD As Date
    Dim enviro As String
    enviro = CStr(Environ("USERPROFILE"))

   MyPath = enviro

   MyPath = MyPath & "\Desktop\OLAttachments\"

    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

    MyFile = Dir(MyPath & "*.txt", vbNormal)

    If Len(MyFile) = 0 Then

        MsgBox "No files were found…", vbExclamation

        Exit Sub

    End If

    Do While Len(MyFile) > 0

        LMD = FileDateTime(MyPath & MyFile)

        If LMD > LatestDate Then

            LatestFile = MyFile

            LatestDate = LMD

        End If

        MyFile = Dir

    Loop

 Workbooks.Open MyPath & LatestFile        

End Sub

Aко ти е необходима повече информация по темата, може да прочетеш тази статия.

Успех!

Comments

Благодаря ви страшно много! Кодът работи безупречно! (bow)