Outlook에서 첨부 파일을 추출하고 제목 줄에 저장하고 잘못된 문자를 제거하려면 어떻게합니까?

Question

많은 수의 첨부 파일을 폴더에 저장하고 필터링해야하는 프로젝트를 진행 중입니다.

현재 첨부 파일을 이메일 제목과 함께 파일 이름으로 저장할 수 있습니다. 첨부 파일이 두 개 이상인 경우 (1) 또는 (2) 등으로 제목 줄로 저장합니다.

나는 현재 내가 (아래 replys에 0m3r의 도움 덕분에) 필요한 대부분의 작업을 수행하는 스크립트를

나는이 스크립트를 완료하는 데 필요한 마지막 것은 특별 caracters을 생략 할 것이다 무언가이다 제목 줄을 파일 이름으로 사용하기 전에 제목 줄. 내가 실행중인 문제는 제목이 정방향 (FW :) 또는 응답 (RE :) 인 경우 프로그램이 파일을 올바르게 저장하지 않는다는 것입니다. ":"는 저장 파일을 손상시키는 것입니다. 예를 들어 제목에 "FW : 여기 2017 요청한 파일이 있습니다"라고 표시되면 파일 확장자없이 "FW"로 저장된 파일이 표시됩니다. 내가 필요한 것은 ":"또는 "FW :"를 제거하는 것입니다.

피사체의 특수 문자를 저장 파일 이름으로 변환 할 때 특수 문자를 제거해야하는 사람이 수정할 수 있습니까?

나는 이것을 수행하기 위해 어레이가 필요할 것이라고 생각하지만, 그것을 구현하는 방법과 스크립트의 어떤 부분을 추가 할 것인지 잘 모르겠습니다.

배열과 같은 것 (< ","| ","/ ","* ","\ ","? "," "" "" "" "")

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 

이

,369으로

변경 필요

Dim strAtmtName   As String 

한 다음 수정하여 For Each loop이 같은

제목과 매크로 일부 놀겠 aroung에서 특수 문자를 omiting 여러 추적 할 수없는 가망 옵션을보고 aroung 뒷조사 내가 솔기 무엇을 마련 한 후

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

내가 필요한 것에 완벽하게 부합하도록

본인의 진료를 받아 주셔서 감사합니다. 아래

코드 :

1. selcet 폴더는 모든 첨부 파일을 저장합니다.
2. 은 그 다음 "_"
3. 수정 된 제목 줄로 파일을 저장하여
4. 내가 정의 특수 문자를 대체 각 이메일의 제목을 가져옵니다.
5. 선택한 모든 이메일에 대해 프로세스를 반복합니다.

붙여 넣기 :

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 

편집 : 전망 VBA에서이 스크립트를 작동하게하는 데 필요한 API 선언에 사용되는 스크립트의

섹션. 이 코드 섹션은 모든 변수를 선상에 선언하기 전에 이동합니다. 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