изменение сценария Vb "mattachmentsaver", чтобы не делать фотографии тела письма и только вложения

Question

Может кто-нибудь, пожалуйста, помогите мне изменить приведенный ниже код, чтобы не снимать фотографии с тела письма (подписи, логотипы и т. Д.).и только берет вложение из самой электронной почты Outlook.Я использую сценарий "mAttachmentSaver" по умолчанию от Microsoft.

Attribute VB_Name = "mAttachmentSaver"
'---------------------------------------------------------------------------------
' The sample scripts are not supported under any Microsoft standard support
' program or service. The sample scripts are provided AS IS without warranty
' of any kind. Microsoft further disclaims all implied warranties including,
' without limitation, any implied warranties of merchantability or of fitness for
' a particular purpose. The entire risk arising out of the use or performance of
' the sample scripts and documentation remains with you. In no event shall
' Microsoft, its authors, or anyone else involved in the creation, production, or
' delivery of the scripts be liable for any damages whatsoever (including,
' without limitation, damages for loss of business profits, business interruption,
' loss of business information, or other pecuniary loss) arising out of the use
' of or inability to use the sample scripts or documentation, even if Microsoft
' has been advised of the possibility of such damages.
'---------------------------------------------------------------------------------

Option Explicit

' *****************
' For Outlook 2010.
' *****************
#If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr

    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr

' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
    ' The window handle of Outlook.
    Private lHwnd As Long

    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If

' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260

' ######################################################
'  Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO              As Object       ' Computer's file system object.
    Dim objShell            As Object       ' Windows Shell application object.
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
    Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
    Dim strAtmtFullName     As String       ' The full name of an attachment.
    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 strAtmtNameTemp     As String       ' To save a temporary attachment file name.
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
    Dim strFolderPath       As String       ' The selected folder path.
    Dim blnIsEnd            As Boolean      ' End all code execution.
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.

    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0

    On Error Resume Next

    Set selItems = ActiveExplorer.Selection

    If Err.Number = 0 Then

        ' Get the handle of Outlook window.
        lHwnd = FindWindow(olAppCLSN, vbNullString)

        If lHwnd <> 0 Then

            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
            Set objShell = CreateObject("Shell.Application")
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

            ' /* Failed to create the Shell application. */
            If Err.Number <> 0 Then
                MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
                       Err.Description & ".", vbCritical, "Error from Attachment Saver"
                blnIsEnd = True
                GoTo PROC_EXIT
            End If

            If objFolder Is Nothing Then
                strFolderPath = ""
                blnIsEnd = True
                GoTo PROC_EXIT
            Else
                strFolderPath = CGPath(objFolder.Self.Path)

                ' /* Go through each item in the selection. */
                For Each objItem In selItems
                    lCountEachItem = objItem.Attachments.Count

                    ' /* If the current item contains attachments. */
                    If lCountEachItem > 0 Then
                        Set atmts = objItem.Attachments

                        ' /* Go through each attachment in the current item. */
                        For Each atmt In atmts

                            ' Get the full name of the current attachment.
                            strAtmtFullName = atmt.FileName

                            ' Find the dot postion in atmtFullName.
                            intDotPosition = InStrRev(strAtmtFullName, ".")

                            ' Get the name.
                            strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                            ' Get the file extension.
                            strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                            ' Get the full saving path of the current attachment.
                            strAtmtPath = strFolderPath & atmt.FileName

                            ' /* If the length of the saving path is not larger than 260 characters.*/
                            If Len(strAtmtPath) <= MAX_PATH Then
                                ' True: This attachment can be saved.
                                blnIsSave = True

                                ' /* Loop until getting the file name which does not exist in the folder. */
                                Do While objFSO.FileExists(strAtmtPath)
                                    strAtmtNameTemp = strAtmtName(0) & _
                                                      Format(Now, "_mmddhhmmss") & _
                                                      Format(Timer * 1000 Mod 1000, "000")
                                    strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)

                                    ' /* If the length of the saving path is over 260 characters.*/
                                    If Len(strAtmtPath) > MAX_PATH Then
                                        lCountEachItem = lCountEachItem - 1
                                        ' False: This attachment cannot be saved.
                                        blnIsSave = False
                                        Exit Do
                                    End If
                                Loop

                                ' /* Save the current attachment if it is a valid file name. */
                                If blnIsSave Then
 If itmOL.BodyFormat = olFormatHTML Then
                        'If the email is HTML type, the embeded picture need special care
                        Dim oPA As Outlook.PropertyAccessor
                        Dim PropName As String
                        Dim PropInfo As String

                        PropName = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
                        Set oPA = itmOL.Attachments.Item(i).PropertyAccessor
                        PropInfo = oPA.GetProperty(PropName)
                        If PropInfo = "Flase" Then atmt.SaveAsFile strAtmtPath
                            Else
                                lCountEachItem = lCountEachItem - 1
                            End If
                        Next
                    End If

                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
                Next
            End If
        Else
            MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If

    ' /* For run-time error:
    '    The Explorer has been closed and cannot be used for further operations.
    '    Review your code and restart Outlook. */
    Else
        MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
        blnIsEnd = True
    End If

PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems

    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (atmt Is Nothing) Then Set atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing

    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
End Function

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
    Dim lNum As Long

    lNum = SaveAttachmentsFromSelection

    If lNum > 0 Then
        MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
    Else
        MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
End Sub

Answer 1

Простая демонстрация ответа, показанного здесь.Скрытые вложения должны быть изображениями.

Различать видимые и невидимые вложения с помощью Outlook VBA

Private Sub AttachmentsHidden()

    Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

    Dim olObj As Object
    Dim olPA As propertyAccessor
    Dim olAtt As Attachment

    ' Open an appropriate mailitem
    Set olObj = ActiveInspector.currentItem

    If olObj.Class = olmail Then

        Debug.Print "  Subject: " & olObj.Subject

        For Each olAtt In olObj.Attachments

            Set olPA = olAtt.propertyAccessor

            If olPA.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
                Debug.Print "   " & olAtt.fileName & vbCr & "    not hidden"
                Debug.Print "    Save this?"
            Else
                Debug.Print "   " & olAtt.fileName & vbCr & "    hidden"
                Debug.Print "    Skip this?"
            End If

        Next

    End If

End Sub

Answer 2

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

Макрос, представленный ниже, является одним из двух, которые я использую для изучения электронных писем, которые я хочу обработать.Когда мне нужна только ограниченная диагностика, я использую версию с Debug.Print.Приведенный ниже макрос выводится в файл рабочего стола с именем «InvestigateEmails.txt».Он выводит как текст, так и HTML-тела, но с возвратом каретки, переводом строки и вкладками, замененными на «{cr}», «{lf}» и «{tb}».Это позволяет мне полностью изучить сообщения электронной почты, если они есть, а не как они отображаются.

Чтобы использовать этот макрос, выберите одно или несколько из этих сообщений электронной почты и запустите макрос InvestigateEmails1.Вам нужно изучить вывод и определить разницу между вложениями, которые вы хотите сохранить, и теми, которые вы не делаете.Как только вы узнаете, как определить разницу, вы сможете задать конкретный вопрос.

Макрос InvestigateEmails1 нуждается в ссылке на "Microsoft Scripting Runtime".Для макроса PutTextFileUtf8NoBom требуется ссылка на «Объекты данных Microsoft ActiveX nn Library».В моей системе «nn» - это «6.1», но макрос должен работать с более ранними версиями.

Public Sub InvestigateEmails1()

  ' Outputs properties of selected emails to a file.

  ' ???????  No record of when originally coded
  ' 22Oct16  Output to desktop file rather than Immediate Window.

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283
  ' Needs reference to "Microsoft Scripting Runtime"

  Dim Exp As Explorer
  Dim FileBody As String
  Dim fso As FileSystemObject
  Dim InxA As Long
  Dim ItemCrnt As MailItem
  Dim Path As String

  Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")

  Set Exp = Outlook.Application.ActiveExplorer

  If Exp.Selection.Count = 0 Then
    Call MsgBox("Please select one or more emails then try again", vbOKOnly)
    Exit Sub
  Else
    FileBody = ""
    For Each ItemCrnt In Exp.Selection
      With ItemCrnt
        FileBody = FileBody & "From (Sender): " & .Sender & vbLf
        FileBody = FileBody & "From (Sender name): " & .SenderName & vbLf
        FileBody = FileBody & "From (Sender email address): " & _
                              .SenderEmailAddress & vbLf
        FileBody = FileBody & "Subject: " & CStr(.Subject) & vbLf
        If .Attachments.Count = 0 Then
          FileBody = FileBody & "No attachments" & vbLf
        Else
          FileBody = FileBody & "Attachments:" & vbLf
          FileBody = FileBody & "No.|Type|Path|Filename|DisplayName|" & vbLf
          For InxA = 1 To .Attachments.Count
            With .Attachments(InxA)
              FileBody = FileBody & InxA & "|"
              Select Case .Type
                Case olByValue
                  FileBody = FileBody & "Val"
                Case olEmbeddeditem
                  FileBody = FileBody & "Ebd"
                Case olByReference
                  FileBody = FileBody & "Ref"
                Case olOLE
                  FileBody = FileBody & "OLE"
                Case Else
                  FileBody = FileBody & "Unk"
              End Select
              ' Not all types have all properties.  This code handles
              ' those missing properties of which I am aware.  However,
              ' I have never found an attachment of type Reference or OLE.
              ' Additional code may be required for them.
              Select Case .Type
                Case olEmbeddeditem
                  FileBody = FileBody & "|"
                Case Else
                  FileBody = FileBody & "|" & .Pathname
              End Select
              FileBody = FileBody & "|" & .Filename
              FileBody = FileBody & "|" & .DisplayName & "|" & vbLf
            End With
          Next
        End If
        Call OutLongText(FileBody, "Text: ", Replace(Replace(Replace(.Body, vbLf, _
                         "{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
        Call OutLongText(FileBody, "Html: ", Replace(Replace(Replace(.HtmlBody, vbLf, _
                         "{lf}" & vbLf), vbCr, "{cr}"), vbTab, "{tb}"))
        FileBody = FileBody & "--------------------------" & vbLf
      End With
    Next
  End If

  Call PutTextFileUtf8NoBom(Path & "\InvestigateEmails.txt", FileBody)

End Sub
Public Sub OutLongText(ByRef TextOut As String, ByVal Head As String, _
                       ByVal TextIn As String)

  ' Break TextIn into lines of not more than 100 characters
  ' and append to TextOut

  Dim PosEnd As Long
  Dim LenOut As Long
  Dim PosStart As Long

  If TextIn <> "" Then
    PosStart = 1
    Do While PosStart <= Len(TextIn)
      PosEnd = InStr(PosStart, TextIn, vbLf)
      If PosEnd = 0 Or PosEnd > PosStart + 100 Then
        ' No LF in remainder of TextIn or next 100 characters
        PosEnd = PosStart + 99
        LenOut = 100
      Else
        ' Output upto LF.  Restart output after LF
        LenOut = PosEnd - PosStart
        PosEnd = PosEnd
      End If
      If PosStart = 1 Then
        TextOut = TextOut & Head
      Else
        TextOut = TextOut & Space(Len(Head))
      End If
      TextOut = TextOut & Mid$(TextIn, PosStart, LenOut) & vbLf
      PosStart = PosEnd + 1
    Loop
  End If

End Sub
Public Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)

  ' Outputs FileBody as a text file named PathFileName using
  ' UTF-8 encoding without leading BOM

  ' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
  ' Addition to original code says version 2.5. Tested with version 6.1.

  '  1Nov16  Copied from http://stackoverflow.com/a/4461250/973283
  '          but replaced literals with parameters.
  ' 15Aug17  Discovered routine was adding an LF to the end of the file.
  '          Added code to discard that LF.
  ' 11Oct17  Posted to StackOverflow
  '  9Aug18  Comment from rellampec suggested removal of adWriteLine from
  '          WriteTest statement would avoid adding LF.
  ' 30Sep18  Amended routine to remove adWriteLine from WriteTest statement
  '          and code to remove LF from file. Successfully tested new version.

  ' References: http://stackoverflow.com/a/4461250/973283
  '             https://www.w3schools.com/asp/ado_ref_stream.asp

  Dim BinaryStream As Object
  Dim UTFStream As Object

  Set UTFStream = CreateObject("adodb.stream")

  UTFStream.Type = adTypeText
  UTFStream.Mode = adModeReadWrite
  UTFStream.Charset = "UTF-8"
  UTFStream.Open
  UTFStream.WriteText FileBody

  UTFStream.Position = 3 'skip BOM

  Set BinaryStream = CreateObject("adodb.stream")
  BinaryStream.Type = adTypeBinary
  BinaryStream.Mode = adModeReadWrite
  BinaryStream.Open

  UTFStream.CopyTo BinaryStream

  UTFStream.Flush
  UTFStream.Close
  Set UTFStream = Nothing

  BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
  BinaryStream.Flush
  BinaryStream.Close
  Set BinaryStream = Nothing

End Sub