我刚刚打开的.msg 文件的文件夹位置

Question

我有 Outlook VBA 代码，可将所有附加项目下载到特定文件夹。

我正在查看的电子邮件以 (.msg) 文件形式保存在文件夹：C:\Users\username\Documents mails 中。我放了一个 MsgBox 来告诉我刚刚打开的电子邮件文件的文件夹位置。

我期望 C:\Users\用户名\Documents 邮件

我尝试过

CurDir()

。这给了我 C:\Users\username\Documents。

以下代码还提供了C:\Users\用户名\Documents。

Sub SaveOlAttachments()
Dim app As Outlook.Application
Dim Msg As Outlook.MailItem
Dim att As Outlook.attachment
Dim strFilePath As String
Dim strAttPath As String
Dim wshell As Object
Set wshell = CreateObject("WScript.Shell")

Set app = New Outlook.Application

'path for creating msgs
strFilePath = wshell.CurrentDirectory & "\emails\"
MsgBox (strFilePath)
'path for saving attachments
strAttPath = strFilePath & "\attachments\"
Do While Len(strFile) > 0
    Set Msg = app.CreateItemFromTemplate(strFilePath & strFile)
    If Msg.Attachments.Count > 0 Then
         For Each att In Msg.Attachments
             att.SaveAsFile strAttPath & att.FileName
         Next
    End If
    strFile = Dir
Loop

End Sub

为什么不加到最后呢？

电子邮件将被移至共享云端硬盘。
电子邮件将与客户相关，因此将为相关电子邮件和附件创建文件夹，以保存与每个客户相关的电子邮件和附件。

例如：

Z:\客户联系人\客户\JoeBlogs
Z:\客户联系人\客户\JoeBlogs 附件）

Z:\客户联系人\客户\JaneDoe
Z:\客户联系人\客户\JaneDoe 附件）

由于要保存的附件的文件夹和位置每次都会改变（取决于正在触发宏的电子邮件），我无法添加到最后。

Answer 1

您可以使用 Excel 对话框导航到该文件夹，然后返回路径：

Private Sub selectedFileLocation()

Dim olMsg As MailItem
Dim olAtt As Attachment

Dim strPath As String
Dim strFile As String

Dim strAttPath As String

Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")

Dim fd As Office.FileDialog
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False

Dim selectedItem As Variant
Dim i As Long

If fd.Show = -1 Then

    For Each selectedItem In fd.SelectedItems
        
        ' select one file, any extension
        Debug.Print "selectedItem: " & selectedItem
        
        i = InStrRev(selectedItem, "\")
        If i > 1 Then
            strPath = Left(selectedItem, i)
            ' Note the backslash at the end
            Debug.Print "strPath.....: " & strPath
            
            strAttPath = strPath & "attachments\"
            Debug.Print "strAttPath..: " & strAttPath
        End If

    Next
End If

xlApp.Quit

Set fd = Nothing
Set xlApp = Nothing

End Sub