Change new mail subject line to name of the attached file - vba

So far I have been able to attach the file programmatically with this:
Private Sub AttachmentFile()
Dim oLook As Object
Dim oMail As Object
Dim FD As Object
Dim vrtSelectedItem As Variant
Set oLook = CreateObject("Outlook.Application")
Set oMail = oLook.CreateItem(0)
Set FD = Excel.Application.FileDialog(3)
With oMail
FD.AllowMultiSelect = True
FD.Filters.Clear
FD.Filters.Add "All Files", "*.*"
FD.InitialFileName = "\\ad\dfs\Shared Data\"
If FD.Show = True Then
For Each vrtSelectedItem In FD.SelectedItems
.Attachments.Add vrtSelectedItem
Next
End If
.Display
End With
Set FD = Nothing
Set oMail = Nothing
Set oLook = Nothing
End Sub
Now that the email is created and I can select the file from a specified folder, I am trying to have the change the mail item's subject to the name of the attached file, also replacing the _ (underscore) with a | (pipe symbol).
Here is the now Working code I have. I also added a signature to the email with correct fonts and image of my default signature in outlook.
Private Sub SubNBodyNTo()
Dim myInspector As Outlook.Inspector
Dim MItem As MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set MItem = myInspector.CurrentItem
Set myAttachments = MItem.Attachments
MItem.Subject = myAttachments.Item(1).DisplayName
MItem.Subject = Replace(MItem.Subject, "_", " | ")
MItem..HTMLBody = MItem.Subject & " Is attached for your approval." & "<br>" & MItem.HTMLBody
MItem.To = "person#email.com"
MItem.CC = "OtherPeople#email.com"
End If
End If
End Sub

Private Sub SubNBodyNTo()
Dim myInspector As Outlook.Inspector
Dim MItem As MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set MItem = myInspector.CurrentItem
Set myAttachments = MItem.Attachments
MItem.Subject = myAttachments.Item(1).DisplayName
MItem.Subject = Replace(MItem.Subject, "_", " | ")
MItem..HTMLBody = MItem.Subject & " Is attached for your approval."
& "<br>" & MItem.HTMLBody
MItem.To = "person#email.com"
MItem.CC = "OtherPeople#email.com"
End If
End If
End Sub

Related

VBA to reply an email but some info is missing

I have written a working code to reply to an email in certain format, however the result is missing some info for the last received email in the Html body (From, sent, to, cc, subject. I'm not even sure if this is called the mail header).
If I click on the Outlook 2013 default 'reply' button, these info would have been auto-generated ahead of the last email, while above it would then be my reply content.
So which function should I use to call these info out? The info must appear in all my replies, so I need to figure it out one way or the other. My code:
'there is a getsignature function before the code.
Public Sub my_reply()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSelection As Outlook.Selection
Dim objMail As Outlook.mailitem
Dim StrSignature As String
StrSignature = GetSignature("C:\Users\xxx\xxx\Microsoft\Signatures\ABC.htm")
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
If objMsg.Class = olMail Then
objMsg.Categories = "Category A"
Set myreply = objMsg.Reply
myreply.To = objMsg.SenderEmailAddress
myreply.BCC = "xxx#abc" & " ; " & "xxx#abc"
myreply.Subject = "XYZ matter" & objMsg.Subject
myreply.Display
myreply.HTMLBody = StrSignature & "<br><br>" & objMsg.HTMLBody
Release:
Set objMsg = Nothing
Set oExplorer = Nothing
End If
Next
End Sub
ReplyAll should get the cc. If you are only concerned about missing text ignore this.
Set myReply = objMsg.ReplyAll
You are overwriting the initial myreply.HTMLBody with objMsg.HTMLBody
myreply.HTMLBody = StrSignature & "<br><br>" & objMsg.HTMLBody
Instead append to the initial myreply.HTMLBody
Option Explicit
Public Sub my_replyAll()
'Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSelection As Selection
'Dim objMail As Outlook.mailitem
Dim myReply As mailitem
Dim StrSignature As String
StrSignature = GetSignature("C:\Users\xxx\xxx\Microsoft\Signatures\ABC.htm")
' Set objOL = CreateObject("Outlook.Application")
'Set objSelection = objOL.ActiveExplorer.Selection
Set objSelection = ActiveExplorer.Selection
For Each objMsg In objSelection
If objMsg.Class = olMail Then
Set myReply = objMsg.ReplyAll
myReply.To = objMsg.SenderEmailAddress
myReply.BCC = "xxx#abc" & " ; " & "xxx#abc"
myReply.Subject = "XYZ matter " & objMsg.Subject
myReply.Display
'myReply.HtmlBody = StrSignature & "<br><br>" & objMsg.HtmlBody
myReply.HtmlBody = StrSignature & "<br><br>" & myReply.HtmlBody
Release:
Set objMsg = Nothing
End If
Next
End Sub

Add contact from messages inside outlook and ignore address already present

I have this VBA code that allows to add contact from an Outlook selected folder or selected messages :
' The AddAddressesToContacts procedure can go in any Module
' Select the mail folder and any items to add to contacts, then run the macro
Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts= oNS.GetDefaultFolder(olFolderContacts)
Set colItems= folContacts.Items
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact= Nothing
bContinue= True
sSenderName= ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = oMail.Subject
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
.Save
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
I would like to go to the next address if the current address exists into the address book.
For the moment, I have this code :
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
But how to ignore the address already recorded in the address book ?
To go to the next address if the current address exists in the address book.
If Not (oContact Is Nothing) Then
bContinue = False
End If

Outlook reply macro not displaying images

I have a macro that will open a reply to a selected email with a template. However, the rest of the images in the email machine now just showe a red cross.
Can anyone see why this might be happening?
Sub TacReply()
Dim origEmail As MailItem
Dim replyEmail As MailItem
Set origEmail = Application.ActiveExplorer.Selection(1)
Set replyEmail = Application.CreateItemFromTemplate("S:\Share\TWGeneral.oft")
replyEmail.To = origEmail.SenderEmailAddress
replyEmail.Subject = origEmail.Subject
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.SentOnBehalfOfName = "email#address.com"
replyEmail.Display
End Sub
Thanks :)
Just in case anyone has the same problem, here was the solution I used:
Sub Forward_Mail_Outlook_With_Signature_Html_2()
Dim MyItem As Object
Dim MyFwdItem As MailItem
Dim SigString As String
Dim Signature As String
Set MyItem = ActiveExplorer.Selection(1).reply
If MyItem.Class = olMail Then
Set MyFwdItem = MyItem.Forward
'Change only Mysig.htm to the name of the signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Your Signature.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
With MyFwdItem
.To = MyFwdItem.SenderEmailAddress
.subject = MyFwdItem.subject
.HTMLBody = "<br>" & Signature & .HTMLBody
.SentOnBehalfOfName = "youremail#address.com"
.Display
End With
Else
MsgBox "Select a mailitem."
End If
ExitRoutine:
Set MyItem = Nothing
Set MyFwdItem = Nothing
End Sub
Private Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Extract Outlook Properties of a sender of a mail

I want to extract properties, like phone number, society, email,... from an e-mail which is in my inbox.
Set oOutlookmail = CreateObject("Outlook.Application")
Set oMyInspectors = oOutlookmail.Inspectors
Set oMail = oMyInspectors.Item(lCount2).CurrentItem
gsDate = Left(oMail.ReceivedTime, InStr(1, oMail.ReceivedTime, " ") - 1)
I can have the date but that's all. I looked with Contact item, we can add contact properties but not get the ones of a mail.
An other solution is to add to contacts the sender and delete it after but I didn't find how to do that.
Phone and other information is not stored in a sender address.
Re: "An other solution is to add to contacts the sender ..."
The limited amount of information available when creating a contact from scratch is described here http://www.slipstick.com/developer/create-contacts-from-messages/.
This macro is compliments of Outlook MVP and developer Ken Slovak from http://www.slovaktech.com
Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts= oNS.GetDefaultFolder(olFolderContacts)
Set colItems= folContacts.Items
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact= Nothing
bContinue= True
sSenderName= ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = oMail.Subject
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
.Save
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
and here https://msdn.microsoft.com/en-us/library/office/ff869056.aspx

Outlook: Attach a file with a dynamic name

Argh, Object doesn't support this property or method error 438!
I haven't tried this but, I think it might work:
objFS.System.IO.Path.GetFileName(fileName)
if objFS.System.IO.Path.GetFileName(fileName) = "VS12_WID1" Then
fileName = AFile.Name
getFileName = filePath & "/" & fileName
I should simplfy it more then try to rename the file.
Sub AddAttachment()
Dim myAttachments As Outlook.Attachments
Dim getFile, fileName, filePath As String
Set filePath = "F:\"
Set fileName = "V_W_*_*_.pdf"
Set getFile = "filePath" & "fileName"
Set MyApp = CreateObject("Outlook.Application")
Set myItem = MyApp.CreateItem(0)
Set myAttachments = myItem.Attachments
With myItem
.To = "email#mail.com"
.CC = ""
.Subject = "test"
myAttachments.Add getFile
.ReadReceiptRequested = False
.HTMLBody = "Report(s) Attached"
End With
myItem.Send
End Sub
I'm getting a compile error: Object required highlighting both Sub AddAttachment() and Set filePath. I feel so close to making this work!
UPDATED CODE:
Sub AddAttachment()
Dim myAttachments As Outlook.Attachments
Dim getFileName, fileName, filePath As String
Dim objFS: Set objFS = CreateObject("Scripting.FileSystemObject")
Set filePath = "F:\"
Set getFileName = filePath & fileName
Set MyApp = CreateObject("Outlook.Application")
Set myItem = MyApp.CreateItem(0)
Set myAttachments = myItem.Attachments
For Each fileName In filePath
If fcase(objFS.GetExtensionName(fileName)) = "VS111111_WID111A" Then
fileName = "VS111111_WID111A.pdf"
Exit For
End If
Next
With myItem
.To = "email#mail.com"
.CC = ""
.Subject = ""
myAttachments.Add getFileName
.ReadReceiptRequested = False
.HTMLBody = "Report(s) Attached"
End With
myItem.Send
End Sub
I have enough knowledge to read the script to understand what is going on. The code I made can only find a fixed file name. How can the file name be made dynamic?
Sub AddAttachment()
Dim myAttachments As Outlook.Attachments
Set MyApp = CreateObject("Outlook.Application")
Set myItem = MyApp.CreateItem(0)
Set myAttachments = myItem.Attachments
With myItem
.To = "email#address.com"
.CC = "email#address.com"
.Subject = ""
myAttachments.Add "F:\constantFilenameHas8char_constantFilenameHas7char_variableHas5Int_todaysModifiedDate_variableHas6Int.pdf"
.ReadReceiptRequested = False
.HTMLBody = "Report(s) Attached"
End With
myItem.Send
End Sub
Your query is not clear on how you want to get the filename.Think of using
a variable and pass the filepath and name as you required.
dim FileToAttach as string
FileToAttach ="FilePath" & "Filename"
myAttachments.Add FileToAttach
For your updated code
Sub AddAttachment()
Dim myAttachments As Outlook.Attachments
Dim getFileName, filename
Dim filePath As Object
Dim objFS As FileSystemObject
Set objFS = New FileSystemObject
Set filePath = objFS.GetFolder("C:\Users\Dinesh\Desktop\")
Set MyApp = CreateObject("Outlook.Application")
Set myItem = MyApp.CreateItem(0)
Set myAttachments = myItem.Attachments
For Each AFile In filePath.Files
Debug.Print UCase(objFS.GetExtensionName(fileName))
If UCase(objFS.GetExtensionName(AFile)) = "PDF" Then
fileName = AFile.Name
getFileName = filePath & "/" & fileName
Exit For
End If
Next
With myItem
.To = ""
.CC = ""
.Subject = ""
myAttachments.Add getFileName
.ReadReceiptRequested = False
.HTMLBody = "Report(s) Attached"
.Display
End With
'myItem.Send
End Sub