群发附件如何选择指定文件夹内的附件

doudoujiejie

本人小白，在论坛里摘抄了一些代码，实现了本文件内的群发附件，请问各位大牛以下代码如何修改，可以实现每次指定新的文件夹内的附件群发？ 非常感谢。

Sub Filename()

    Dim fso, fl, m&
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each fl In fso.getfolder(ThisWorkbook.Path).Files
        m = m + 1
        Cells(m + 1, 1) = fl.Name
        Cells(m + 1, 5) = fl.Path
   Next

End Sub

Sub sendemail()

    Dim myOlApp As Object
    Dim myitem As Object
    Dim i As Integer, j As Integer
    Dim strg As String
    Dim atts As Object
    Dim mycc As Object
    Dim myfile As String

    Set myOlApp = CreateObject("Outlook.Application")

    With Sheets("Sheet1")
        i = 2

        Do While .Cells(i, 2) <> ""
            Set myitem = myOlApp.CreateItem(0)
           Set atts = myitem.Attachments
            myitem.To = .Cells(i, 2)              '收件人E-mail
            myitem.Subject = .Cells(i, 3)            '标题
            myitem.Body = vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4)   '正文
            myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")
            Do Until myfile = ""
                 myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile, 1
                myfile = Dir
            Loop
            myitem.send '预览，如果想直接发送，把.display改为.send

            i = i + 1
            strg = ""
        Loop
    End With
    Set myitem = Nothing
End Sub