VBA Для отправки почты с помощью Filesearch

Question

У меня есть этот код для отправки почты нескольким получателям с использованием Lotus Notes. Прямо сейчас мне нужно указать весь путь к файлам для вложений. Мое требование - использовать метод 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, был обратно в July 26, 2011 Так что будьте осторожны, если я пропущу любой синтаксис. не : р

Application.FileSearch метод больше не поддерживается XL2007 +

Reference: Error message when you run a macro to search for a file in an Office 2007 program: "Run-time error 5111"

В случае, если вышеуказанное соединение умирает, вот снимок экрана.

Как уже упоминалось в этой ссылке Вы можете использовать FileSystemObject объект для рекурсивного поиска каталогов и найти определенные файлы. Here is how we do that

В случае установки ссылки на эту ссылку, код программы с указанной ссылки.

'~~> 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 

После того, как вы можете выбрать файлы, которые вы можете использовать следующий код в цикле, чтобы добавить вложения

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