如何读取Outlook当前文件夹路径，实现脚本适配任意文件夹？

原脚本因硬编码邮箱与文件夹路径，仅能在指定位置运行。要实现无需手动调整路径、适配任意文件夹的需求，可通过动态获取选中邮件的所在文件夹来修改代码：

修改后的完整代码 #

Option Explicit

Public Sub MailSpeichern()
    ' 变量声明
    Dim olApp As Outlook.Application
    Dim SelectedItem As Object
    Dim CurrentFolder As Outlook.MAPIFolder
    Dim TempFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim lngCount As Long
    
    ' 获取当前选中的邮件
    Set SelectedItem = Application.ActiveExplorer.Selection(1)
    ' 动态获取选中邮件所在的文件夹
    Set CurrentFolder = SelectedItem.Parent
    
    ' 初始化Outlook应用（直接使用当前实例，无需重新创建）
    Set olApp = Outlook.Application
    ' 定位当前文件夹下的temp子文件夹
    Set TempFolder = CurrentFolder.Folders("temp")
    
    ' 保存并移动选中邮件到temp文件夹
    SelectedItem.Close olSave
    SelectedItem.Move TempFolder
    Debug.Print "已移动邮件: " & SelectedItem.Subject
    
    ' 遍历temp文件夹，将邮件移回原文件夹
    Set Items = TempFolder.Items
    For lngCount = Items.Count To 1 Step -1
        Set SelectedItem = Items(lngCount)
        Debug.Print "处理邮件: " & SelectedItem.Subject
        If SelectedItem.Class = olMail Then
            ' 移回原文件夹（当前选中邮件的所在文件夹）
            SelectedItem.Move CurrentFolder
        End If
    Next lngCount
    
    ' 释放对象资源
    Set SelectedItem = Nothing
    Set CurrentFolder = Nothing
    Set TempFolder = Nothing
    Set Items = Nothing
    Set olApp = Nothing
End Sub

关键修改说明 #

1. 移除硬编码路径：通过SelectedItem.Parent直接获取选中邮件的所在文件夹，替代原代码中固定的address@email.org与Posteingang路径
2. 动态定位temp文件夹：基于当前邮件所在文件夹查找temp子文件夹，确保脚本在任意文件夹下都能找到目标操作目录
3. 适配移动逻辑：将后续邮件移动的目标从固定收件箱改为当前文件夹，保持操作上下文一致

可选增强：自动创建temp文件夹 #

如果需要避免因temp文件夹不存在导致的报错，可在定位TempFolder前添加以下判断逻辑：

' 检查temp文件夹是否存在，不存在则自动创建
On Error Resume Next
Set TempFolder = CurrentFolder.Folders("temp")
On Error GoTo 0
If TempFolder Is Nothing Then
    Set TempFolder = CurrentFolder.Folders.Add("temp", olFolderInbox)
End If

内容的提问来源于stack exchange，提问作者Stealth