Как я могу изменить результат этого кода, чтобы сохранить вложения, а не сообщения? - PullRequest
Новая
       60

Как я могу изменить результат этого кода, чтобы сохранить вложения, а не сообщения?

0 голосов
/ 28 июня 2019

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

Я пытался создавать с использованием C # и не очень эффективно справлялся с тем, что мне удалось достичь.

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

    Option Explicit
'This macro not required for Rule script
Sub Save_Messages()
Dim olItem As MailItem
Dim fPath As String
    fPath = BrowseForFolder(CStr(Environ("USERPROFILE")) & "\desktop\") & Chr(92)
    For Each olItem In Application.ActiveExplorer.Selection
        If olItem.Class = OlObjectClass.olMail Then
            SaveMessage olItem, fPath
            DoEvents
        End If
    Next olItem
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Sub SaveMessage(olItem As MailItem, fPath As String)
'Sub SaveMessage(olItem As MailItem) 'Alternative for rule script
'Const fPath As String = "C:\Path\" 'Set Path - required for rule script
Dim Fname As String
Dim dtDate As Date
    dtDate = olItem.ReceivedTime
    Fname = olItem.Subject
    Fname = Fname & " - " & "[" & olItem.SenderName + "]"
    Fname = Format(dtDate, "yymmddKT", vbUseSystemDayOfWeek, _
                   vbUseSystem) & " - " & Fname & " - {" & _
                   Format(dtDate, "hh.mm", _
                          vbUseSystemDayOfWeek, _
                          vbUseSystem) & "}"
    Fname = Replace(Fname, Chr(58) & Chr(41), "")
    Fname = Replace(Fname, Chr(58) & Chr(40), "")
    Fname = Replace(Fname, Chr(34), "-")
    Fname = Replace(Fname, Chr(42), "-")
    Fname = Replace(Fname, Chr(47), "-")
    Fname = Replace(Fname, Chr(58), "-")
    Fname = Replace(Fname, Chr(60), "-")
    Fname = Replace(Fname, Chr(62), "-")
    Fname = Replace(Fname, Chr(63), "-")
    Fname = Replace(Fname, Chr(124), "-")
    SaveUnique olItem, fPath, Fname
lbl_Exit:
    Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

'Following function not required for Rule script
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
    Exit Function

Invalid:
    BrowseForFolder = False
End Function

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

Ответы [ 2 ]

0 голосов
/ 29 июня 2019

Я уверен, что мы можем сделать лучше, но здесь попробуйте это ..... 

Option Explicit
'This macro not required for Rule script

Dim FldrName As String

Sub Save_Messages()
    Dim olItem As MailItem
    Dim fPath As String
    Dim Atmt As Outlook.Attachment


    fPath = BrowseForFolder(CStr(Environ("USERPROFILE")) & "\desktop\") & Chr(92)
    For Each olItem In Application.ActiveExplorer.selection
        If olItem.Class = OlObjectClass.olMail Then

            For Each Atmt In olItem.Attachments
                DoEvents

                SaveMessage olItem, fPath

                Atmt.SaveAsFile FldrName & "\" & Atmt.DisplayName

            Next

        End If
    Next olItem

    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Sub SaveMessage(olItem As MailItem, fPath As String)
'Sub SaveMessage(olItem As MailItem) 'Alternative for rule script
'Const fPath As String = "C:\Path\" 'Set Path - required for rule script
Dim Fname As String
Dim dtDate As Date
    dtDate = olItem.ReceivedTime
    Fname = olItem.Subject

    Fname = Fname
    Fname = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
                   vbUseSystem) & " - " & Fname
    Fname = Replace(Fname, Chr(58) & Chr(41), "")
    Fname = Replace(Fname, Chr(58) & Chr(40), "")
    Fname = Replace(Fname, Chr(34), "-")
    Fname = Replace(Fname, Chr(42), "-")
    Fname = Replace(Fname, Chr(47), "-")
    Fname = Replace(Fname, Chr(58), "-")
    Fname = Replace(Fname, Chr(60), "-")
    Fname = Replace(Fname, Chr(62), "-")
    Fname = Replace(Fname, Chr(63), "-")
    Fname = Replace(Fname, Chr(124), "-")


    Debug.Print fPath, Fname

    FldrName = fPath & Fname

    Debug.Print FldrName

    CreateDir FldrName

lbl_Exit:
    Exit Sub
End Sub


'Following function not required for Rule script
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
    Exit Function

Invalid:
    BrowseForFolder = False
End Function

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
0 голосов
/ 28 июня 2019

Это потому, что вы сохраняете сообщение, а не только вложения. Добавьте следующую строку в раздел DIM: 

Dim objAttachments As Outlook.Attachments, i as Integer, lngCount as Integer

Затем в разделе For Each удалите эти (2) строки sName = sName + ".msg"; msg.SaveAs sName, olMsg и замените их следующим текстом: 

Set objAttachments = msg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then
    For i = lngCount To 1 Step -1
        objAttachments.Item(i).SaveAsFile sName & lngCount
    Next i
End If
...