タイトルに禁止文字を含むメールの保存 

## 元コード

https://kunohe.tech/outlook-vba/1763/

OutlookVBAは書籍も記事も少ない中最近見つけた超面白くて参考になる方。
書籍も即ポチしました。
[エクセルVBAerのためのOutlook VBA入門](https://techbookfest.org/product/6493257867460608?productVariantID=6391309973585920)

## 元コードに追加したこと
### フォルダやファイル保存時に怒られる禁止文字を含む場合、それを`_`に変換した
とりあえずこれくら列挙したけど追加があればここに追加します。

``` vb
Prohibits = Array("\", "/", "?", "<", ">", "|", ":")
```

### 添付ファイルを指定フォルダ１か所に集めるようにした
元のコードだとメール1通ごとに添付資料がバラバラのフォルダに保存されるので、何往復もやりとりがあるタイプ向けに指定フォルダ１か所に集めるようにしました。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/833acaa3-feb7-90ef-9655-9e5baddc2ad0.png)



## コード(標準モジュール)

``` vb

Option Explicit
'保存先アドレスを定数PATHに登録
Const PATH As String = "C:\Users\ユーザ名\Desktop\フォルダ名"
'添付ファイルは別フォルダ1か所に固めたい場合
Const Dir_添付資料 = "添付資料"

Private Function 禁止文字の処理(ByVal TargetStr) As String
  Dim buf: buf = TargetStr
  Dim Prohibits:  Prohibits = Array("\", "/", "?", "<", ">", "|", ":")
  Const AfterStr = "_"
  
  Dim i
  For i = 0 To UBound(Prohibits)
    buf = Replace(buf, Prohibits(i), AfterStr)
  Next
  禁止文字の処理 = buf
End Function

Private Function 相対フォルダ指定(ByVal ParentPath, TargetPath) As String
  Dim buf: buf = Split(ParentPath, "\")
  Dim ub: ub = UBound(buf)
  buf(ub) = TargetPath
  Dim NewPath: NewPath = Join(buf, "\")
  相対フォルダ指定 = NewPath
End Function

Sub 添付保存(ByVal Item As Object)

'フォルダ名はメール受信日yyyymmdd＋件名とする
  Dim strItemPath As String
  strItemPath = PATH & "\" & Format(Item.ReceivedTime, "yyyymmdd_") & 禁止文字の処理(Item.Subject)
  
  strItemPath = 重複処理(strItemPath)

'フォルダを作ってメール本体を保存する
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CreateFolder strItemPath
  
  Item.SaveAs strItemPath & "\" & 禁止文字の処理(Item.Subject) & ".msg"

'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"

  With Item
    For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
        Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then

            strFile = 相対フォルダ指定(strItemPath, Dir_添付資料) & "\" & objAttachment.fileName
            strFile = 重複処理(strFile)
            objAttachment.SaveAsFile strFile

        End If
    Next objAttachment
  End With
  
  '各オブジェクト達をNothingで消しておく
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub


Function 重複処理(ByVal strName)

 '同名ファイル・フォルダがあれば通し番号を追加

  Dim strCheckName As String
  Dim i As Integer

  strCheckName = strName
  
  i = 1
    
  Do While Dir(strCheckName, vbDirectory) <> ""
    If InStr(strCheckName, ".") <> 0 Then
      strCheckName = Left(strName, InStrRev(strName, ".") - 1) & "(" & i & ")" & Mid(strName, InStrRev(strName, "."))
    Else
      strCheckName = strName & "(" & i & ")"
    End If
    i = i + 1
  Loop
  
  重複処理 = strCheckName

End Function
```


## 残課題
### msgファイル名をメールタイトルではなく本文の要約分にしたい
選択中の文字列を拾ってinputboxの初期値にしておいて、微妙に文言を変えたい場合はそこをいじる

**選択中の文字列を拾って**←ここがわからない

でもたぶんこれやっちゃうと末尾の連番付与で時系列つけてたっぽい流れがわからなくなるので日付付与部にhhmmまでつけて結構長いファイル名になりそうではある。。。

### 最初のフォルダ指定を変動にしたい
今の業務パターンだとフォルダ名にボール持ち主を入れて管理するので都度あいまい検索的に指定しないといけないのでちょっと骨が折れそう。

``` vb
Const PATH As String = "C:\Users\ユーザ名\Desktop\フォルダ名"
```