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

Question

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

В настоящее время я могу сохранить вложения с темой письма как имя файла. Если имеется более одного вложения, оно сохраняет в качестве строки темы (1) или (2) и так далее.

я в настоящее время есть скрипт, который будет делать большую часть того, что мне нужно (Благодаря помощи от 0m3r в нижеприведенном отвечено)

Последнее, что мне нужно, чтобы завершить этот сценарий является то, что будет пропускать специальный caracters из строка темы, прежде чем она использует строку темы в качестве имени файла. Проблема, с которой я сталкиваюсь, заключается в том, что программа не сохраняет файлы правильно, если объект является Forward (FW :) или Reply (RE :) Я подозреваю, что «:» - это то, что разрушает файл сохранения. Например, если Тема читает «FW: Вот файл, который вы запросили 2017», то, что я получаю, является файлом, сохраненным как «FW» без расширения файла. Мне нужно удалить «:» или «FW:», чтобы этого не произошло.

Может ли кто-нибудь предоставить мне исправление, мне нужно удалить специальные символы из темы в качестве конвертированного в имя файла сохранения?

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

Что-то вроде Array ("<", ">", "|", "/", "*", "\", "?", "" ")

Public Function SaveAttachmentsFromSelection() As Long 
Dim objFSO    As Object  
Dim objShell   As Object  
Dim objFolder   As Object  
Dim objItem    As Object  
Dim selItems   As Selection  
Dim atmt    As Attachment 
Dim strAtmtPath   As String  
Dim strAtmtFullName  As String  
Dim strAtmtName   As String  
Dim strAtmtNameTemp  As String  
Dim intDotPosition  As Integer  
Dim atmts    As Attachments 
Dim lCountEachItem  As Long   
Dim lCountAllItems  As Long   
Dim strFolderPath  As String  
Dim blnIsEnd   As Boolean  
Dim blnIsSave   As Boolean  

blnIsEnd = False 
blnIsSave = False 
lCountAllItems = 0 

On Error Resume Next 

Set selItems = ActiveExplorer.Selection 

If Err.Number = 0 Then 

    lHwnd = FindWindow(olAppCLSN, vbNullString) 

    If lHwnd <> 0 Then 

     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) 

     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) 

      For Each objItem In selItems 
       lCountEachItem = objItem.Attachments.Count 

       If lCountEachItem > 0 Then 
        Set atmts = objItem.Attachments 

        For Each atmt In atmts 
         strAtmtFullName = atmt.FileName 
         intDotPosition = InStrRev(strAtmtFullName, ".") 
         strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition) 
         strAtmtPath = strFolderPath & objItem.subject & Chr(46) & strAtmtName 

         Dim lngF As Long 
         lngF = 1 

         If Len(strAtmtPath) <= MAX_PATH Then 
          blnIsSave = True 
          Do While objFSO.FileExists(strAtmtPath) 

           strAtmtNameTemp = objItem.subject & "(" & lngF & ")" 

           strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName 

           If Len(strAtmtPath) > MAX_PATH Then 
            lCountEachItem = lCountEachItem - 1 
            blnIsSave = False 
            Exit Do 
           End If 

          lngF = lngF + 1 
          Loop 

          If blnIsSave Then atmt.SaveAsFile strAtmtPath 
         Else 
          lCountEachItem = lCountEachItem - 1 
         End If 
        Next 
       End If 

       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 

Else 
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver" 
    blnIsEnd = True 
End If 

PROC_EXIT: 
SaveAttachmentsFromSelection = lCountAllItems 

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 

If blnIsEnd Then End 
End Function 

Public Function CGPath(ByVal Path As String) As String 
If Right(Path, 1) <> "\" Then Path = Path & "\" 
CGPath = Path 
End Function 

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

Вам нужно изменить ваш For Each loop, попробуйте это ...

изменить этот

Dim strAtmtName(1)  As String 

к этому

Dim strAtmtName   As String 

А затем изменить ваш For Each loop как это

For Each Atmt In atmts 
    strAtmtFullName = Atmt.FileName 
    intDotPosition = InStrRev(strAtmtFullName, ".") 
    strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition) 
    strAtmtPath = strFolderPath & objItem.Subject & Chr(46) & strAtmtName 

    Dim lngF As Long 
    lngF = 1 

    If Len(strAtmtPath) <= MAX_PATH Then 
     blnIsSave = True 
     Do While objFSO.FileExists(strAtmtPath) 

      strAtmtNameTemp = objItem.Subject & "(" & lngF & ")" 

      strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName 

      If Len(strAtmtPath) > MAX_PATH Then 
       lCountEachItem = lCountEachItem - 1 
       blnIsSave = False 
       Exit Do 
      End If 

      lngF = lngF + 1 
     Loop 

Answer 2

После некоторого копания aroung глядя на несколько Возможное вариантов Omiting специальные символы из строки темы и некоторые играющая aroung с макро я пришел с тем, что швы отлично работать для того, что мне нужно.

Благодарим 0m3r за вашу помощь в решении этой проблемы.

Код ниже:

1. selcet папку для сохранения всех вложений в.
2. Затем он тянет строку темы каждого письма
3. заменяет специальные символы Я определяю с «_»
4. Сохранением файла в качестве модифицированной сюжетной линии.
5. Повторяет процесс для каждого выбранного сообщения.

Paste:

Public Function SaveAttachmentsFromSelection() As Long 
Dim objFSO    As Object 
Dim objShell   As Object 
Dim objFolder   As Object 
Dim objItem    As Outlook.MailItem 
Dim selItems   As Selection 
Dim atmt    As Attachment 
Dim strAtmtPath   As String 
Dim strAtmtFullName  As String 
Dim strAtmtName   As String 
Dim strAtmtNameTemp  As String 
Dim intDotPosition  As Integer 
Dim atmts    As Attachments 
Dim lCountEachItem  As Long 
Dim lCountAllItems  As Long 
Dim strFolderPath  As String 
Dim blnIsEnd   As Boolean 
Dim blnIsSave   As Boolean 
Dim strPrompt   As String, strname As String 
Dim sreplace   As String, mychar As Variant 
blnIsEnd = False 
blnIsSave = False 
lCountAllItems = 0 
On Error Resume Next 
Set selItems = ActiveExplorer.Selection 
If Err.Number = 0 Then 
    lHwnd = FindWindow(olAppCLSN, vbNullString) 
    If lHwnd <> 0 Then 
     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) 
     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) 
      For Each objItem In selItems 
       lCountEachItem = objItem.Attachments.Count 
       If lCountEachItem > 0 Then 
        Set atmts = objItem.Attachments 

        If objItem.Class = olMail Then 
         If objItem.subject <> vbNullString Then 
          strname = objItem.subject 
         Else 
          strname = "No_Subject" 
         End If 
        sreplace = "_" 
        For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦") 
        'do the replacement for each character that's illegal 
         strname = Replace(strname, mychar, sreplace) 
        Next mychar 
        End If 
        For Each atmt In atmts 
         strAtmtFullName = atmt.FileName 
         intDotPosition = InStrRev(strAtmtFullName, ".") 
         strAtmtName = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition) 
         strAtmtPath = strFolderPath & strname & Chr(46) & strAtmtName 
         Dim lngF As Long 
         lngF = 1 
         If Len(strAtmtPath) <= MAX_PATH Then 
          blnIsSave = True 
          Do While objFSO.FileExists(strAtmtPath) 
           strAtmtNameTemp = strname & "(" & lngF & ")" 
           strAtmtPath = strFolderPath & strAtmtNameTemp & Chr(46) & strAtmtName 
           If Len(strAtmtPath) > MAX_PATH Then 
            lCountEachItem = lCountEachItem - 1 
            blnIsSave = False 
            Exit Do 
           End If 
          lngF = lngF + 1 
          Loop 
          If blnIsSave Then atmt.SaveAsFile strAtmtPath 
         Else 
          lCountEachItem = lCountEachItem - 1 
         End If 
        Next 
       End If 
       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 
Else 
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver" 
    blnIsEnd = True 
End If 
PROC_EXIT: 
SaveAttachmentsFromSelection = lCountAllItems 
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 
If blnIsEnd Then End 
End Function 
Public Function CGPath(ByVal Path As String) As String 
If Right(Path, 1) <> "\" Then Path = Path & "\" 
CGPath = Path 
End Function 
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 

Edit:

Раздел сценария используется для объявлений API, которые необходимы, чтобы сделать эту работу скрипта в мировоззрениях VBA. Этот раздел кода идет до того, как вы объявите все свои переменные выше строки Public Function SaveAttachmentsFromSelection() As Long

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