VBA使用Filesearch发送邮件

我有这个代码使用Lotus Notes发送邮件给多个收件人。 现在我需要提到附件的整个文件path。 我的要求是使用FileSearch方法 – 提及* *中的附件名称的任何部分 – 以便附加文件。

 Sub Send() Dim oSess As Object Dim oDB As Object Dim oDoc As Object Dim oItem As Object Dim direct As Object Dim Var As Variant Dim flag As Boolean Dim cell As Range Dim r As Excel.Range Dim Name As String Dim Annex As String Dim recp As Variant Dim cc As Variant Dim Resp As Long Resp = MsgBox(prompt:="Do you wish to send to the mail?", Buttons:=vbYesNo + vbInformation + vbDefaultButton2, Title:=AppHeader) If Resp = vbYes Then Sheets("Sheet2").Activate For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants) If cell.Value Like "?*@?*.?*" And _ LCase(Cells(cell.Row, "E").Value) = "yes" Then Set oSess = CreateObject("Notes.NotesSession") Set oDB = oSess.GETDATABASE("", "") Call oDB.OPENMAIL flag = True If Not (oDB.IsOpen) Then flag = oDB.Open("", "") If Not flag Then MsgBox "Can't open mail file: " & oDB.SERVER & " " & oDB.FILEPATH GoTo exit_SendAttachment End If On Error GoTo err_handler 'Building Message recp = Cells(cell.Row, "B").Value cc = Cells(cell.Row, "C").Value Set oDoc = oDB.CREATEDOCUMENT Set oItem = oDoc.CREATERICHTEXTITEM("BODY") oDoc.Form = "Memo" oDoc.Subject = "HI" & "-" & Cells(cell.Row, "D").Value oDoc.sendto = Split(recp, ",") oDoc.copyto = Split(cc, ",") oDoc.body = "Dear " & Cells(cell.Row, "A").Value _ & vbNewLine & vbNewLine & _ "Please find attached " oDoc.postdate = Date oDoc.SaveMessageOnSend = True Name = Cells(cell.Row, "F").Value Annex = Cells(cell.Row, "G").Value Call oItem.EmbedObject(1454, "", Name) Call oItem.EmbedObject(1454, "", Annex) oDoc.Send False End If Next cell MsgBox prompt:="Mail Sent", Buttons:=vbOKOnly + vbInformation, Title:=AppHeader Exit Sub 'Attaching DATABASE For Each r In Range("Fpath") '// Change to suit If r.Value <> vbNullString Then Call Send End If Next oDoc.visable = True 'Sending Message exit_SendAttachment: On Error Resume Next Set oSess = Nothing Set oDB = Nothing Set oDoc = Nothing Set oItem = Nothing 'Done err_handler: If Err.Number = 7225 Then MsgBox "File doesn't exist" Else MsgBox Err.Number & " " & Err.Description End If On Error GoTo exit_SendAttachment Else Sheets("Sheet1").Activate End If End Sub 

任何想法将不胜感激。

Answer 1

我已经使用Lotus笔记已经有好几年了。 我在Lotus Notes上回答的最后一个问题是在2011年7月26日回来的。所以如果我错过了任何语法，请对我温柔一点。 ：p

XL2007 +不再支持Application.FileSearch方法

参考 ： 运行macros来searchOffice 2007程序中的文件时出现错误信息：“运行时错误5111”

如果上面的链接死了，这里是截图。

正如在该链接中提到的那样您可以使用FileSystemObject对象recursionsearch目录并查找特定的文件。 这是我们如何做到的

如果上述链接死亡，这里是该链接的代码。

 '~~> COURTESY: http://support.microsoft.com/kb/185601 Option Explicit Dim fso As New FileSystemObject Dim fld As Folder Private Sub Command1_Click() Dim nDirs As Long, nFiles As Long, lSize As Currency Dim sDir As String, sSrchString As String sDir = InputBox("Type the directory that you want to search for", _ "FileSystemObjects example", "C:\") sSrchString = InputBox("Type the file name that you want to search for", _ "FileSystemObjects example", "vb.ini") MousePointer = vbHourglass Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..." lSize = FindFile(sDir, sSrchString, nDirs, nFiles) MousePointer = vbDefault MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _ " directories", vbInformation MsgBox "Total Size = " & lSize & " bytes" End Sub Private Function FindFile(ByVal sFol As String, sFile As String, _ nDirs As Long, nFiles As Long) As Currency Dim tFld As Folder, tFil As File, FileName As String On Error GoTo Catch Set fld = fso.GetFolder(sFol) FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _ vbHidden Or vbSystem Or vbReadOnly) While Len(FileName) <> 0 FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _ FileName)) nFiles = nFiles + 1 List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox FileName = Dir() ' Get next file DoEvents Wend Label1 = "Searching " & vbCrLf & fld.Path & "..." nDirs = nDirs + 1 If fld.SubFolders.Count > 0 Then For Each tFld In fld.SubFolders DoEvents FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles) Next End If Exit Function Catch: FileName = "" Resume Next End Function 

一旦你能够select文件，你可以在循环中使用下面的代码来添加附件

 stAttachment = "Blah Blah.Txt" Set obAttachment = oDoc.CreateRichTextItem("stAttachment") Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)