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。如果我错过任何语法，请对我保持温和。的：P

XL2007 +
不再支持
Application.FileSearch方法
参考：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)

VBA使用Filesearch发送邮件

1 个答案: