Vba 从列表框中选择要在电子邮件中附加的多个项目

我建立了一个包含多个文件的数据库，比如用户手册。我在Access中创建的表单之一是一个搜索字段，它使用查询查找用户要查找的特定文件。搜索将结果缩小到一个列表框中，双击该列表框将为您打开该文件。结果还根据文档类型缩小为选项卡。我已经实现了一个功能，如果您选择（文件）结果以突出显示它，然后单击按钮，它会将该文件插入MS Outlook中的新邮件中。这很好，但我想在同一封电子邮件中选择多个文件。我一直在网上到处搜索，似乎找不到合适的解决方案。我将在下面列出我的代码

这第一块代码在我的搜索表中

Private Sub cmdEMail_Click()

Dim fpath As String

'Find out what tab user is on
Select Case Me!tabResults.Value
Case 0
    If IsNull(lstManResults.Column(5, lstManResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstManResults.Column(5, lstManResults.ListIndex)
    End If
Case 1
    If IsNull(lstBullResults.Column(5, lstBullResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstBullResults.Column(5, lstBullResults.ListIndex)
    End If
Case 2
    If IsNull(lstSubResults.Column(5, lstSubResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstSubResults.Column(5, lstSubResults.ListIndex)
    End If
Case 3
        If IsNull(lstPicResults.Column(5, lstPicResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstPicResults.Column(5, lstPicResults.ListIndex)
    End If
Case 4
    If IsNull(lstWarrResults.Column(5, lstWarrResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstWarrResults.Column(5, lstWarrResults.ListIndex)
    End If
Case 5
    If IsNull(lstPartResults.Column(5, lstPartResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstPartResults.Column(5, lstPartResults.ListIndex)
    End If
Case 6
    If IsNull(lstSchemResults.Column(5, lstSchemResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstSchemResults.Column(5, lstSchemResults.ListIndex)
    End If
Case 7
    If IsNull(lstAppResults.Column(5, lstAppResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstAppResults.Column(5, lstAppResults.ListIndex)
    End If
Case 8
    If IsNull(lstSpecResults.Column(5, lstSpecResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstSpecResults.Column(5, lstSpecResults.ListIndex)
    End If
Case 9
    If IsNull(lstInternalResults.Column(5, lstInternalResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstInternalResults.Column(5, lstInternalResults.ListIndex)
    End If
Case 10
    If IsNull(lstAddenSuppResults.Column(5, lstAddenSuppResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstAddenSuppResults.Column(5, lstAddenSuppResults.ListIndex)
    End If
Case 11
    If IsNull(lstVideoResults.Column(5, lstVideoResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstVideoResults.Column(5, lstVideoResults.ListIndex)
    End If
Case 12
    If IsNull(lstTechTipsResults.Column(5, lstTechTipsResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstTechTipsResults.Column(5, lstTechTipsResults.ListIndex)
    End If
Case 13
    If IsNull(lstArchiveResults.Column(5, lstArchiveResults.ListIndex)) Then
        Exit Sub
    Else
        fpath = lstArchiveResults.Column(5, lstArchiveResults.ListIndex)
    End If
End Select

EmailDoc fpath

End Sub

此代码是我创建的用于处理电子邮件操作的函数：

Function EmailDoc(ByVal fpath As String)

'Get Outlook if it isn't open already
Set outlookApp = CreateObject("Outlook.Application")
Set outlookItem = outlookApp.CreateItem(0)

If Err <> 0 Then
    'Outlook wasn't running, start it
    Set outlookApp = CreateObject("Outlook.Application")
    Started = True
End If

With outlookItem
    .to = ""
    .Subject = "Requested Document"
    .Body = "Thank you"
    .attachments.Add (fpath)

    .display

End With

End Function

函数EmailDoc（ByVal fpath作为字符串）
'如果Outlook尚未打开，则获取Outlook
设置outlookApp=CreateObject（“Outlook.Application”）
Set-outlookItem=outlookApp.CreateItem（0）
如果错误为0，则
“Outlook没有运行，请启动它
设置outlookApp=CreateObject（“Outlook.Application”）
开始=真
如果结束
带了望项目
.to=“”
.Subject=“请求的文档”
.Body=“谢谢”
.attachments.Add（fpath）
.展示
以
端函数

任何帮助都将不胜感激。

请尝试以下两个链接：

---

它们显示了处理多个列表框选择的两种不同方式。

我认为这样做会让您朝着正确的方向前进。或