Hello, I am currently using the code below to save a file and send an email with a link to the file on our server. What I would also like to do is before the email is sent, look through outlook folders and find an attachment based on a range value in the worksheet. When it finds the attachment I would like to transfer it into the same folder that we are saving the current file into. This project is the first time that I have tried to do anything with outlook from excel so I am having trouble figuring out how to make this work.
Sub CreateFolderandSaveFile()
Dim wb As Workbook
Dim ws As Worksheet
Dim suffix, suffix1, fName, fName1, fName2, fpath, As String,
Set wb = ThisWorkbook
Set ws = ThisWorkbook.Sheets("Change Order Report")
Set ws2 = ThisWorkbook.Sheets("Hidden For VBA")
If Range("CORCODesc") = "" Then
MsgBox "Please enter a general description for this Change Order"
Range("CORCODesc").Select
Exit Sub
Else
'Do Nothing
End If
If Range("CORProjectNo") = "" Then
MsgBox "Please enter a Project Number"
Range("CORProjectNo").Select
Exit Sub
Else
'Do Nothing
End If
If Range("CORCONo") = "" Then
MsgBox "Please enter a Change Order Number"
Range("CORCONo").Select
Exit Sub
Else
'Do Nothing
End If
For Each Cell In Range("Directory")
If Cell = "" Then
'do nothing
ElseIf Len(Dir(Cell, vbDirectory)) = 0 Then
MkDir Cell
End If
Next Cell
suffix = ".xlsm"
suffix1 = ".pdf"
fpath = Range("COFolder") & "\"
fName = Range("CORProjectNo") & " CO-" & Range("CORCONo") & " " & Range("CORCODesc") _
& " Qty. " & Range("CORLine1Qty") & " COReportBA"
fName1 = fpath + fName + suffix
fName2 = fpath & Range("CORCustPONo") + suffix1
wb.SaveAs fName1, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "font size=""3"" face=""Calibri"">" & _
"Hello :br B" & _
fName & "/B COR has been created.<br>" & _
"Click " & _
"A HREF=""file://" & fName1 & _
"""HereA" & _
" to open the live file." & _
"brClick " & _
"A HREF ""file://" & fName2 & _
"""Her</A>" & _
" to open the PO." & _
"<br><br>A copy of the COR has also been attached." & _
"<br><br><br>Regards," & _
"<br><br>Sales</font>"
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "A New Change Order Report has been Entered for job " & Range("CORProjectNo")
.HTMLBody = strbody
.Attachments.Add fName1
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Bookmarks