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

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

Option Explicit

Sub リスト作成()

    Const TEXT_FILE = "リスト.txt" ' 保存するファイル名を指定。ドキュメントに保存される
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim strStart As String
    Dim strEnd As String
    Dim objOL As Object
    Dim objNAMESPC As Object
    Dim strFilter As String
    Dim myfolders As Object
    Dim objMail As MailItem
    Dim colItems As Items
    Dim objAttach As Attachment
    Dim strAttach As String
    Dim cnt As Long

    '受信日時の設定
    dtStart = Date - 1
    dtEnd = Date - 1
    strStart = FormatDateTime(dtStart, vbShortDate) & " 00:00"
    strEnd = FormatDateTime(dtEnd, vbShortDate) & " 23:59"
    strFilter = "[受信日時] >= '" & strStart & _
                 "' AND [受信日時] <= '" & strEnd & "'"

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

    'メールフォルダをフィルタリング
    Set colItems = myfolders.Items.Restrict(strFilter)

    'テキストドキュメントにメールの情報を転記
        Open TEXT_FILE For Output As #1
           For Each objMail In colItems
            With objMail
                Print #1, "差出人:" & vbTab & .SenderName
                Print #1, "送信日時:" & vbTab & .SentOn
                If .To <> "" Then
                    Print #1, "宛先:" & vbTab & .To
                End If
                If .CC <> "" Then
                    Print #1, "ＣＣ:" & vbTab & .CC
                End If
                Print #1, "件名:" & vbTab & .Subject
                If .Attachments.Count > 0 Then
                    strAttach = ""
                    For Each objAttach In .Attachments
                        strAttach = strAttach & objAttach.Filename & "; "
                    Next
                    strAttach = Left(strAttach, Len(strAttach) - 2)
                    Print #1, "添付ファイル: " & vbTab & strAttach
                End If
                If .Importance <> olImportanceNormal And .Sensitivity <> olNormal Then
                    Print #1, ""
                End If
                If .Importance = olImportanceHigh Then
                    Print #1, "重要度:" & vbTab & "高"
                End If
                If .Importance = olImportanceHigh Then
                    Print #1, "重要度:" & vbTab & "低"
                End If
                If .Sensitivity = olConfidential Then
                    Print #1, "秘密度:" & vbTab & "社外秘"
                End If
                If .Sensitivity = olPersonal Then
                    Print #1, "秘密度:" & vbTab & "個人用"
                End If
                If .Sensitivity = olPrivate Then
                    Print #1, "秘密度:" & vbTab & "親展"
                End If
                If .Categories <> "" Then
                    Print #1, ""
                    Print #1, "分類項目:" & vbTab & .Categories
                End If
                Print #1, ""
                objMail.Body = Replace(objMail.Body, vbLf, vbCr)
                Print #1, .Body
                Print #1, ""
            End With
        Next
    'テキストドキュメントを閉じる
    Close #1

Application.ScreenUpdating = False '画面表示更新の一時停止
Application.Calculation = xlCalculationManual '関数の計算の一時停止

Open TEXT_FILE For Input As #1

Dim r As Long
    '2行目から書き出す
    r = 2

    Do Until EOF(1)
    Dim buf As String
        Line Input #1, buf

        Dim aryline As Variant '文字列格納用配列変数
        aryline = Split(buf, vbTab) '読み込んだ行をタブ区切りで配列変数に格納

        Dim i As Long
        For i = LBound(aryline) To UBound(aryline)

            'W2から転記開始
            Cells(r, i + 23).Value = "'" & aryline(i)

        Next

        r = r + 1

    Loop

Close #1

Application.ScreenUpdating = True '画面表示更新の再開
Application.Calculation = xlCalculationAutomatic '関数の計算の再開

End Sub