将电子邮件移入文件夹 - 检查按字母顺序排列的文件夹是否已存在，如果不存在则创建新文件夹，然后将内容放入

Question

对 vba 来说相当陌生，但创建了以下代码，如果在字母文件中找不到它，它会创建一个新文件夹。文件夹结构是 A-Z，在示例中您可以看到我设法让它创建文件夹，但它没有检查“P”文件夹以查看它是否已经存在 - 我在“P 文件夹”中粘贴了一个名为“Person Test 12345678”，它应该将其添加到那里，但它没有在“P 文件夹”中查找。我的代码做错了什么？

Sub MoveEmailsToHardDriveFolder()
    Dim olApp As Object
    Dim olNs As Object
    Dim olInbox As Object
    Dim subFolder As Object
    Dim olItems As Object
    Dim olItem As Object
    Dim subjectKeyword As String
    Dim hardDrivePath As String
    Dim subfolderPath As String
    Dim filePath As String

    ' Set the keyword to identify emails to be moved based on the subject
    subjectKeyword = "PSAmend"

    ' Set the root path of the hard drive folder where you want to move the emails
    hardDrivePath = "\\nch\dfs\SharedArea\HR\HR-PC\Employee Files\CURRENT STAFF\"

    ' Create Outlook Application and Namespace objects
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")

    ' Set the Inbox folder
    Set olInbox = olNs.GetDefaultFolder(6) ' 6 corresponds to the Inbox folder, change it if needed

    ' Set the subfolder within the Inbox (adjust the subfolder name as needed)
    Set subFolder = olInbox.Folders("Contracts")

    ' Set the Items collection in the subfolder
    Set olItems = subFolder.Items

    ' Loop through each email in the subfolder
    ' On Error Resume Next ' Enable error handling
    For Each olItem In olItems
        ' Check if the subject contains the specified keyword
        If InStr(1, olItem.Subject, subjectKeyword, vbTextCompare) > 0 Then
            ' Get the subject as the subfolder name
            subfolderPath = Replace(olItem.Subject, ":", "_")

            ' Use the subject and subfolder as the file path
            filePath = hardDrivePath & subfolderPath & "\" & Replace(olItem.Subject, ":", "_") & ".msg"

            ' Create the subfolder if it doesn't exist
            If Dir(hardDrivePath & subfolderPath, vbDirectory) = "" Then
                MkDir hardDrivePath & subfolderPath
            End If

            ' Save the email as a .msg file to the specified path
            olItem.SaveAs filePath, 3 ' 3 corresponds to olMSG format

            ' Move the email to the specified destination folder (optional)
            ' olItem.Move destFolder
        End If
    Next olItem
    ' On Error GoTo 0 ' Disable error handling

    ' Clean up objects
    Set olItem = Nothing
    Set olItems = Nothing
    Set subFolder = Nothing
    Set olInbox = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub

我在“P 文件夹”中粘贴了一个名为“Person Test 12345678”的文件，它应该已将其添加到其中，但它没有在“P 文件夹”中查找。我的代码做错了什么：

Answer 1

将字母文件夹添加到

hardDrivePath

的末尾。

Dim subfolderAlpha As String
subfolderAlpha = UCase(Left(subjectKeyword, 1)) & "\"
hardDrivePath = hardDrivePath & subfolderAlpha