匯出outlook 某資料庫來所有的附件

Public Sub SaveAttachments()
        Dim SaveToPath As String
        Dim dateFormat
        Dim Str As String
        Str = Right(CStr(10000 + CInt(9000 * Rnd)), 4) + "-"

        SaveToPath = "D:\Email_att\"  '附件儲存位置 

        '由目前選訂的資料夾
        myfolder = Application.ActiveExplorer.CurrentFolder

        For Each myitem In myfolder.Items
            If myitem.Attachments.Count > 0 Then If Dir(SaveToPath, vbDirectory) = "" Then MkDir SaveToPath

            For Each myattachment In myitem.Attachments
                Dim MyFile As String
                  
                MyFile = Dir(SaveToPath & Str & myattachment.FileName)
                If MyFile <> "" Then Str = Right(CStr(10000 + CInt(9000 * Rnd)), 4) + "-"
                MyFile = Dir(SaveToPath & Str & myattachment.FileName)
                If MyFile <> "" Then Str = Right(CStr(10000 + CInt(9000 * Rnd)), 4) + "-"


                myattachment.SaveAsFile SaveToPath & Str & myattachment.FileName

            Next
        Next

        MsgBox("完成")
    End Sub