Outlook VBAについて

OutlookのVBAについて質問です。

現在添付画像のコードで
選択しているメールから指定のExcelのB2に受信日時 C2に件名を書き出しております。

このコードを
1、選択しているメールが複数でも書き出す
2、選択しているメールをmsgファイルとしてExcelにリンクを貼り付け(ALのセルに)エクセル上からクリックでメールを開けるようにする

この2つの処理を追加できる方がおりましたら、是非コードを教えて頂きたいです。

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2023/07/10 17:09

写真にコードを追加する事は出来ませんが

OutlookのVBA
１，選択しているメールが複数でも書き出す
一例です
Sub test()
Dim objSelect As Outlook.Selection
Set objSelect = Outlook.Application.ActiveExplorer.Selection
Dim i As Long
For i = 1 To objSelect.Count
With objSelect.Item(i)
'ここに処理
Debug.Print .Subject

End With
Next
Set objSelect = Nothing
End Sub

2、選択しているメールをmsgファイルとしてExcelにリンクを貼り付け・・
この場合、msgファイルとして保存する必要があるのでは？（Outlook使わないのでよく知らないけれど）

Debug.Print .Subjectの部分に
.SaveAs "FilePath" & "\" & i & "FileName" & ".msg"　みたいな感じ
FileNameを何処から取得するか少し課題が残りそう
（ファイル名に出来ない文字列を全角にしているようなので理解されているかと）

OutlookとExcelの処理は分けた方が問題が起こりにくいです
（そのようになっていそう）

Outlook処理
文字列取得　ファイルパス＆ファイル名作成取得　を取得　msgファイル保存

Excel処理
文字列出力
ファイルパス＆ファイル名でリンク作成埋め込み

ざっくり一例です
サンプル実行条件　デスクトップに　AAAフォルダがあり、aaa.xlsxがあること　2度目の処理（.msg上書き）については未検証
配列を使用してOutlookとExcelの処理を分けています
アプリケーション操作なのでApplication.WaitやDoEventsが必要かも
ブックは閉じていない（未保存）

"olMail"を作成したstrSubjectにすれば良いかも

Sub test()

Dim folPath As String, WSH As Variant
Set WSH = CreateObject("WScript.Shell")
folPath = WSH.SpecialFolders("Desktop")
Set WSH = Nothing

Dim objSelect As Outlook.Selection
Set objSelect = Outlook.Application.ActiveExplorer.Selection
Dim i As Long
ReDim strSubject(1 To objSelect.Count), strAddress(1 To objSelect.Count)
For i = 1 To objSelect.Count
With objSelect.Item(i)
Debug.Print .Subject
strSubject(i) = .Subject
strAddress(i) = folPath & "\AAA\" & i & "olMail" & ".msg"
.SaveAs strAddress(i) '保存
End With
Next
Set objSelect = Nothing

Dim objExcel As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Set objExcel = New Excel.Application
objExcel.Visible = True
Set wb = objExcel.Workbooks.Open(folPath & "\" & "aaa.xlsx")
Set ws = wb.Worksheets(1)
Dim n As Long
n = ws.Cells(ws.Rows.Count, "AL").End(xlUp).Row + 1
For i = 1 To UBound(strAddress)
ws.Hyperlinks.Add Anchor:=ws.Cells(i, "AL"), Address:=strAddress(i), TextToDisplay:=strSubject(i)
Next
' wb.Close
objExcel.Quit
Set objExcel = Nothing
Set wb = Nothing
Set ws = Nothing
End Sub

追記：作成したコードがある場合は写真投稿でなく実際のソースコードを
投稿した方が回答が得られやすいです
ご質問の処理コードに合わせた回答も得られやすいです