Experts,
Can please advise how to check the file name with the address book and return the email address in the To field.
Scenario:
In a folder I have multiple excel files saved with different person names. I am having macro to attach the files in a separate email message.
Now, I need a macro to check the file name with the address book, if found then the corresponding email address should come in the To field. If not found then a default email address(xxxx@.com) to be displayed in the to field. Please advise how to modify/include in the code.
Below is the code.
Can please advise how to check the file name with the address book and return the email address in the To field.
Scenario:
In a folder I have multiple excel files saved with different person names. I am having macro to attach the files in a separate email message.
Now, I need a macro to check the file name with the address book, if found then the corresponding email address should come in the To field. If not found then a default email address(xxxx@.com) to be displayed in the to field. Please advise how to modify/include in the code.
Below is the code.
Code:
Sub SendFilesByEmail()
Dim sFName As String
Dim i As Integer
Dim olApp As Object
Dim oFSO As Object
Dim fldName As String
fldName = BrowseForFolder("Select the folder with the files to be attached.")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Not oFSO.FolderExists(fldName) Then
MsgBox "The folder '" & fldName & "' does not exist"
GoTo lbl_Exit
End If
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
'Outlook wasn't running, start it from code
MsgBox "This function is much faster and more reliable if Outlook is already running." & vbCr & _
"Start Outlook and run the macro again"
Set olApp = Nothing
GoTo lbl_Exit
End If
i = 0
sFName = Dir(fldName)
Do While Len(sFName) > 0
Call SendasAttachment(fldName & sFName) 'send the path and filename
sFName = Dir
i = i + 1
DoEvents
Loop
MsgBox i & " Emails were Drafted"
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub
Function SendasAttachment(fname As String)
Dim olApp As Object
Dim olMsg As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim Strbody As String
On Error GoTo lbl_Exit
Set olApp = GetObject(, "Outlook.Application")
Set olMsg = olApp.CreateItem(0) ' email
On Error Resume Next
' send message
With olMsg
.BodyFormat = 2
.To = ""
.CC = "xxxx@xxxx;"
.Subject = "Access Rights for Year " & Format(Now, "YYYY")
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'Preserve the default signature
oRng.Collapse 1
'as we added the path to the variable, remove it as it is not relevant to the message
' oRng.Text = "Hi " & olMsg.To & "," & vbCr & vbCr & "I have attached " & _
Mid(fname, InStrRev(fname, Chr(92)) + 1) & " as you requested."
Strbody = "<BODY style=font-size:11pt;font-family:Tahoma>Dear <br><br>" & _
Regards,<br>" & _
"Team</BODY>"
.HTMLBody = Strbody
.attachments.Add fname
.Save
'.Display
' .send
End With
lbl_Exit:
'Clean up
Set olMsg = Nothing
Set olApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Function
End Function
Public Function BrowseForFolder(Optional strTitle As String) As String
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFolder = vbNullString
Resume lbl_Exit
End Function
