【ExcelVBA】Outlookの現在開いているフォルダを取得したい

解決したいこと

ExcelVBAからOutlookの現在開いているフォルダを取得するにはどうすればよいでしょうか？
現在はOutlookのフォルダを指定する形ですが、そうすると別の人がExcelVBAからOutlookの情報を取得できません。
そうではなく誰が実行しても問題ないような仕様にしたいです。

お忙しいところ恐縮ですが、お知恵をお借りしたく思います。

対象コード

以下はOutlookフォルダを指定していますが、アクティブなフォルダを指定する形にしたいです。

VBA
1'保存したいメールフォルダを取得
2    Set objOL = CreateObject("Outlook.Application")
3    Set objNAMESPC = objOL.GetNamespace("MAPI")
4    Set myfolders = objNAMESPC.Folders("自分のメールアドレス") _
5                              .Folders("フォルダ名")

全体コード

VBA
1Option Explicit
2
3Sub リスト作成()
4
5    Const TEXT_FILE = "リスト.txt" ' 保存するファイル名を指定。ドキュメントに保存される
6    Dim dtStart As Date
7    Dim dtEnd As Date
8    Dim strStart As String
9    Dim strEnd As String
10    Dim objOL As Object
11    Dim objNAMESPC As Object
12    Dim strFilter As String
13    Dim myfolders As Object
14    Dim objMail As MailItem
15    Dim colItems As Items
16    Dim objAttach As Attachment
17    Dim strAttach As String
18    Dim cnt As Long
19    
20    '受信日時の設定
21    dtStart = Date - 1
22    dtEnd = Date - 1
23    strStart = FormatDateTime(dtStart, vbShortDate) & " 00:00"
24    strEnd = FormatDateTime(dtEnd, vbShortDate) & " 23:59"
25    strFilter = "[受信日時] >= '" & strStart & _
26                 "' AND [受信日時] <= '" & strEnd & "'"
27                 
28     '保存したいメールフォルダを取得
29    Set objOL = CreateObject("Outlook.Application")
30    Set objNAMESPC = objOL.GetNamespace("MAPI")
31    Set myfolders = objNAMESPC.Folders("自分のメールアドレス") _
32                              .Folders("フォルダ名")
33    
34    'メールフォルダをフィルタリング
35    Set colItems = myfolders.Items.Restrict(strFilter)
36    
37    'テキストドキュメントにメールの情報を転記
38        Open TEXT_FILE For Output As #1
39           For Each objMail In colItems
40            With objMail
41                Print #1, "差出人:" & vbTab & .SenderName
42                Print #1, "送信日時:" & vbTab & .SentOn
43                If .To <> "" Then
44                    Print #1, "宛先:" & vbTab & .To
45                End If
46                If .CC <> "" Then
47                    Print #1, "ＣＣ:" & vbTab & .CC
48                End If
49                Print #1, "件名:" & vbTab & .Subject
50                If .Attachments.Count > 0 Then
51                    strAttach = ""
52                    For Each objAttach In .Attachments
53                        strAttach = strAttach & objAttach.Filename & "; "
54                    Next
55                    strAttach = Left(strAttach, Len(strAttach) - 2)
56                    Print #1, "添付ファイル: " & vbTab & strAttach
57                End If
58                If .Importance <> olImportanceNormal And .Sensitivity <> olNormal Then
59                    Print #1, ""
60                End If
61                If .Importance = olImportanceHigh Then
62                    Print #1, "重要度:" & vbTab & "高"
63                End If
64                If .Importance = olImportanceHigh Then
65                    Print #1, "重要度:" & vbTab & "低"
66                End If
67                If .Sensitivity = olConfidential Then
68                    Print #1, "秘密度:" & vbTab & "社外秘"
69                End If
70                If .Sensitivity = olPersonal Then
71                    Print #1, "秘密度:" & vbTab & "個人用"
72                End If
73                If .Sensitivity = olPrivate Then
74                    Print #1, "秘密度:" & vbTab & "親展"
75                End If
76                If .Categories <> "" Then
77                    Print #1, ""
78                    Print #1, "分類項目:" & vbTab & .Categories
79                End If
80                Print #1, ""
81                objMail.Body = Replace(objMail.Body, vbLf, vbCr)
82                Print #1, .Body
83                Print #1, ""
84            End With
85        Next
86    'テキストドキュメントを閉じる
87    Close #1
88    
89Application.ScreenUpdating = False '画面表示更新の一時停止
90Application.Calculation = xlCalculationManual '関数の計算の一時停止
91
92Open TEXT_FILE For Input As #1
93    
94Dim r As Long
95    '2行目から書き出す
96    r = 2
97    
98    Do Until EOF(1)
99    Dim buf As String
100        Line Input #1, buf
101        
102        Dim aryline As Variant '文字列格納用配列変数
103        aryline = Split(buf, vbTab) '読み込んだ行をタブ区切りで配列変数に格納
104
105        Dim i As Long
106        For i = LBound(aryline) To UBound(aryline)
107        
108            'W2から転記開始
109            Cells(r, i + 23).Value = "'" & aryline(i)
110            
111        Next
112        
113        r = r + 1
114    
115    Loop
116    
117Close #1
118
119Application.ScreenUpdating = True '画面表示更新の再開
120Application.Calculation = xlCalculationAutomatic '関数の計算の再開
121
122End Sub
123
124