I am a beginner.
Here is the code that I managed to realize which has for objective that when a person sends me a mail, and that this mail contains an attachment, I want that it saves the piece in a folder.
Except that it writes me an error concerning the line: " typeatt = IsEmbedded(strID, PJ.Index)"
And this code is made for all the received mails and not only the concerned person.
Can anyone help me vsp?
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem
Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)
If MyMail.Attachments.Count > 0 Then
sender = Item.SenderEmailAddress
If sender = "e.marques#octo-am.com" Then 'changer adresse mail
expediteur = MyMail.SenderEmailAddress
Repertoire = "C:\Users\assistant.gestion.3\Desktop\TEST" & "\" 'changer adresse
If Repertoire <> "" Then
If "" = Dir(Repertoire, vbDirectory) Then
MkDir Repertoire
End If
End If
Dim PJ, typeatt
For Each PJ In MyMail.Attachments
typeatt = IsEmbedded(strID, PJ.Index)
If typeatt = "" Then
If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
MsgBox Repertoire & PJ.FileName & "Deja Fait"
If "" = Dir(Repertoire & "old", vbDirectory) Then
MkDir Repertoire & "old"
End If
FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName
End If
PJ.SaveAsFile Repertoire & PJ.FileName
End If
Next PJ
MyMail.UnRead = False
MyMail.Save
Dim myDestFolder As Outlook.MAPIFolder
Set myDestFolder = MyMail.Parent.Folders("test")
MyMail.Move myDestFolder
Else: End Sub
End If
End If
Set MyMail = Nothing
Set olNS = Nothing
End Sub
define the function and solve the problem concerning the person sending the email
This code works perfectly for a normal inbox, but how to change the code to trigger an acknowledgement (only for new mails, need to exclude Re and Forward mails the comes to the inbox folder) from a shared mailbox (xxx#mail.com).folder(inbox)
how to modify this code to trigger from a specific shared mailbox "Inbox"
Public WithEvents xlItems As Outlook.Items
Private Sub Application_Startup()
Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Full Code:
Public WithEvents xlItems As Outlook.Items
Private Sub Application_Startup()
Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub xlItems_ItemAdd(ByVal objItem As Object)
Dim xlReply As MailItem
Dim xStr As String
If objItem.Class <> olMail Then Exit Sub
Set xlReply = objItem.Reply
With xlReply
xStr = "<p>" & "Hi Team, Acknowledging that we have received the Job. Thank you!" & "</p>"
.HTMLBody = xStr & .HTMLBody
.Send
End With
End Sub
I tried Modifying the code but it did not work
Option Explicit
Private WithEvents olInboxItems As Items
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olInboxItems = objNS.Folders("xxxxxxxx#gmail.com").Folders("Inbox").Items
Set objNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim xlReply As MailItem
Dim xStr As String
If objItem.Class <> olMail Then Exit Sub
Set xlReply = objItem.Reply
With xlReply
xStr = "<p>" & "Hi Team, Acknowledging that we have received the Job. Thank you!" & "</p>"
.HTMLBody = xStr & .HTMLBody
.Send
End Sub
This should be more robust than checking for "Re: " and "Fw: " in the subject.
In ThisOutlookSession
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public WithEvents olItems As Items
Private Sub Application_Startup()
Set olItems = Session.Folders("xxxx#xxx.com").Folders("Inbox").Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim olReply As MailItem
If Item.Class = olMail Then
If Len(Item.ConversationIndex) > 44 Then
Exit Sub
Else
Set olReply = Item.reply
With olReply
.Body = "Reply to first email."
.Display
End With
End If
End If
End Sub
I figured the code myself finally. But it sends out mail for all the emails including (RE and FWD)
Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set olItems = objNS.Folders("xxxx#xxx.com").Folders("Inbox").Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim olReply As MailItem
If Item.Class = olMail Then
Set olReply = Item.Reply
Else
Exit Sub
End If
With olReply
'Type Your Own Auto Reply
'Change "John Smith" to Your Own Name
.Body = "This is a test auto reply." & vbCrLf & vbCrLf & "-------Original Message-------" & vbCrLf & "From: " & Item.Sender & "[mailto: " & Item.SenderEmailAddress & "]" & vbCrLf & "Sent: " & Item.ReceivedTime & vbCrLf & "To: YourName" & vbCrLf & "Subject: " & Item.Subject & vbCrLf & Item.Body
.Send
End With
End Sub
This is the primitive / intuitive version.
Subject must remain unchanged and be in English.
In ThisOutlookSession
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public WithEvents olItems As Items
Private Sub Application_Startup()
Dim objNS As namespace
Set objNS = GetNamespace("MAPI")
Set olItems = objNS.Folders("xxxx#xxx.com").Folders("Inbox").Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim olReply As MailItem
If Item.Class = olMail Then
If Left(UCase(Item.Subject), 4) = UCase("Re: ") Or _
Left(UCase(Item.Subject), 4) = UCase("Fw: ") Then
Exit Sub
Else
Set olReply = Item.reply
With olReply
.Body = "Reply to first email."
.Display
End With
End If
End If
End Sub
I currently use a code that generates an email fine with certain fields like To, CC, BCC, but I am not sure how to switch the "FROM" part of the email automatically.
Ie my email is here, but I want to automatically switch to another inbox,
I can do it manually when the email is generated via the drop down, but I am wondering if there are ways to do this automatically. I Tried adding .From to this existing code but does not work.
Here are the relevant snippets of code:
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)
With Mitem
'send to:
.To = send_list
'send from:
'.From = from_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
.From = from_list is not a supported property.
Does anyone know how to alter this code to add the "From" parameter correctly?
FULL CODE
Sub Create_Email()
' Creates e-mail to send
Application.ScreenUpdating = False
Sheets("Emails Management").Select
ActiveSheet.Calculate
top_line_emails = 2 'hardcoded to row 2
max_row_emails = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1 'last row
ref_title_line = Application.WorksheetFunction.Match("Email Name", Columns(1), False) 'gets title row
indexActive = Application.WorksheetFunction.Match("Active", Rows(ref_title_line), False)
indexType = Application.WorksheetFunction.Match("Type", Rows(ref_title_line), False)
indexEmailName = Application.WorksheetFunction.Match("Email Name", Rows(ref_title_line), False)
indexsubject = Application.WorksheetFunction.Match("Subject", Rows(ref_title_line), False)
indexfiles = Application.WorksheetFunction.Match("Attachments", Rows(ref_title_line), False)
indexSendTo = Application.WorksheetFunction.Match("Send To", Rows(ref_title_line), False)
indexSendFrom = Application.WorksheetFunction.Match("Send From", Rows(ref_title_line), False)
indexCC = Application.WorksheetFunction.Match("CCed", Rows(ref_title_line), False)
indexBCC = Application.WorksheetFunction.Match("BCCed", Rows(ref_title_line), False)
indexGreetings = Application.WorksheetFunction.Match("Greetings", Rows(ref_title_line), False)
indexBody = Application.WorksheetFunction.Match("Body Text", Rows(ref_title_line), False)
indexSignature = Application.WorksheetFunction.Match("Signature", Rows(ref_title_line), False)
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Dim oMail As Object
Set fso = CreateObject("Scripting.FileSystemObject")
user_name = Environ("Username")
ref_row = top_line_emails 'hardcoded for row 2
'finds the reports that were generated
Do While ref_row <= max_row_emails
Set OLook = CreateObject("Outlook.Application")
Set Mitem = OLook.CreateItem(0)
Set OlAttachment = Mitem.attachments
send_list = ""
from_list = ""
cc_list = ""
bcc_list = ""
attach_name = ""
whole_text = ""
Body_text = ""
If Range(ColumnNumberToLetter(indexEmailName) & ref_row).Value = "" Then 'looping down the rows, if it is blank stop generating emails.
Exit Do
End If
go_for_it = True
If go_for_it = True Then
file_name = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
send_list = Range(ColumnNumberToLetter(indexSendTo) & ref_row)
from_list = Range(ColumnNumberToLetter(indexSendFrom) & ref_row)
cc_list = Range(ColumnNumberToLetter(indexCC) & ref_row)
bcc_list = Range(ColumnNumberToLetter(indexBCC) & ref_row)
Signature = Range(ColumnNumberToLetter(indexSignature) & ref_row).Value
attachment = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value 'not attaching
'On Error GoTo no_email, Gets the text of the Email
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexGreetings) & ref_row)
'This section gets the text part of the email.
If remail = "" Then
greetings_text = ""
Else
greetings_text = RangetoHTML2(remail)
greetings_text = get_date_cnv(greetings_text, ref_date_email)
End If
'Body text , Meant for charts
If Range(ColumnNumberToLetter(indexBody) & ref_row).Value <> "" Then
body_full_text = Range(ColumnNumberToLetter(indexBody) & ref_row).Value
'count the number of < in the body text
graphic_count = Len(body_full_text) - Len(Replace(body_full_text, "<", ""))
For Count = 1 To graphic_count
'search the start and end of the graphic range
body_start_search = InStr(1, body_full_text, "<")
body_end_search = InStr(1, body_full_text, ">")
'if there are <> then go for it
If body_start_search <> 0 And body_end_search <> 0 Then
'isolate the text in the <>
graphic_area = RTrim(LTrim(Mid(Left(body_full_text, body_end_search), body_start_search)))
'make sure the <> is not a <br> (line break)
If graphic_area <> "" And graphic_area <> "<br>" Then
'body_text = body_text & Left(body_full_text, body_start_search - 1)
graphic_area = Replace(Replace(graphic_area, "<", ""), ">", "")
'pull out the graphic type
graphic_type_search = InStr(1, graphic_area, ",")
graphic_type = Left(graphic_area, graphic_type_search - 1)
graphic_area = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_type_search)))
'pull out the tab name
graphic_tab_search = InStr(1, graphic_area, ",")
graphic_tab = Left(graphic_area, graphic_tab_search - 1)
'pull out the graphic area
graphic_rng = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_tab_search)))
Select Case LCase(graphic_type)
Case "chart"
Body_text = Body_text & "<br>" & RangetoHTML(Sheets(graphic_tab).Range(graphic_rng))
Case "text"
Body_text = Body_text & "<br>" & RangetoHTML2(Sheets(graphic_tab).Range(graphic_rng))
'Need to put graph part here
End Select
If Len(body_full_text) = body_end_search Then
Exit For
End If
body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
Else
If IsEmpty(Body_text) Then
Body_text = Left(body_full_text, body_start_search - 1)
Else
If Len(body_full_text) = body_end_search Then
Exit For
End If
Body_text = Body_text & "<br>" & Left(body_full_text, body_start_search - 1)
End If
If Len(body_full_text) = body_end_search Then
Exit For
End If
body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
End If
Else
Body_text = Body_text & body_full_text & "<br>"
End If
Next Count
Body_text = Body_text & "<br>" & body_full_text
End If
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexBody) & ref_row)
'signature
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexSignature) & ref_row)
end_text = RangetoHTML2(remail)
'creates the whole text in email
whole_text = greetings_text & "<br>" & Body_text & "<br>" & "<br>" & end_text
'create email, but does not send
Set Mitem = OLook.CreateItem(0)
With Mitem
.SendUsingAccount = GetAccountOf("email#blah.com", OLook)
.Display
'send to:
.To = send_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
'attaching files
On Error GoTo resume_here
If Range(ColumnNumberToLetter(indexfiles) & ref_row).Value <> "" Then
file_name = Sheets("Emails Management").Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
file_count = Len(file_name) - Len(Replace(file_name, ";", "")) + 1
For Count = 1 To file_count
file_search = InStr(1, file_name, ";")
If file_search = 0 Then
attach_name = RTrim(LTrim(file_name))
Else
attach_name = RTrim(LTrim(Left(file_name, file_search - 1)))
End If
ref_date = Sheets("Start").Range("D2").Value
attach_name = get_date_cnv(attach_name, ref_date)
file_name = Right(file_name, Len(file_name) - file_search)
file_name = get_date_cnv(file_name, ref_date_email)
.attachments.Add attach_name
Next Count
End If
resume_here:
'email subject
.Subject = get_date_cnv(Range(ColumnNumberToLetter(indexsubject) & ref_row).Value, ref_date_email)
'email body
.HTMLBody = whole_text
'.HTMLBody = graphic_desc
'check names in outlook
.Recipients.ResolveAll
'display email
'.Display
'save as draft
.Save
'.Send
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End With
DoEvents
End If
ref_row = ref_row + 1
Loop
Set fso = Nothing
Set OLook = Nothing
Set Mitem = Nothing
Set OlAttachment = Nothing
Exit Sub
no_email:
MsgBox ("Error creating emails: " & Err.Description)
Set fso = Nothing
Set OLook = Nothing
Set Mitem = Nothing
Set OlAttachment = Nothing
Exit Sub
End Sub
Try this function
Function GetAccountOf(sEmailAddress As String, ByRef OLook As Object) As Object
Dim oAccount As Object
Set GetAccountOf = Nothing
For Each oAccount In OLook.Session.Accounts
If oAccount = sEmailAddress Then
Set GetAccountOf = oAccount
Exit Function
End If
Next oAccount
End Function
You can then replace the .From line with:
.SendUsingAccount = GetAccountOf("emailaddress#somewhere.com", OLook)
Edit: Follow-up to comments below:
If the above doesn't work then I suspect there's something with your outlook that is causing this. You need to think of ways/questions to help determine the problem, such as
Is the account you want to use completely set-up within outlook?
When you send email manually from this account does outlook ask you for password?
Try also to think of test code you can use to narrow down the possibilities that may be the cause of the problem. for example try to run these subroutines and see if the first code actually lists your desired account. Does the second code result in the account being Nothing? If so, perhaps an option is to delete the account and add it again to outlook, which may help reset something that was causing the problem.
Sub ShowAllAccounts()
Dim OLook As Object
Dim oAccount As Object
Set OLook = CreateObject("Outlook.Application")
For Each oAccount In OLook.Session.Accounts
MsgBox oAccount.DisplayName
Next oAccount
End Sub
Sub DoesAccountExist()
Dim OLook As Object
Set OLook = CreateObject("Outlook.Application")
If GetAccountOf("emailaddress#somewhere.com", OLook) Is Nothing Then
MsgBox "Account doesn't exist"
End If
End Sub
Try to make up some other code similar to this and please get back if you are still stuck.
Edit 2:
You need to make sure you set the SendUsingAccount property before you .Display your email: Outlook if funny like that :)
Try this:
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)
With Mitem
.SendUsingAccount = GetAccountOf("emailaddress#somewhere.com", OLook)
.Display
'send to:
.To = send_list
'send from:
'.From = from_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
Try the next approach, please:
Sub SendUsingDifferentAccount()
Dim OLook As New Outlook.Application
Dim acc As Outlook.account
Dim Mitem As Outlook.MailItem
Set Mitem = OLook.CreateItem(0)
For Each acc In OLook.Session.accounts
If acc.DisplayName = "testaccount#yourdomain.com" Then
With Mitem
.To = "..."
.cc = "..."
.BCC = "..."
Set .SendUsingAccount = acc
.send
End With
Exit For
End If
Next
End Sub
If needs a reference to 'Microsoft Outlook ... Object Library. Or declare all above object variables As Object`. But it is better to reference Outlook. You can benefit of the intellisense advantage...
You can use the .SendUsingAccount property
https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.sendusingaccount
I use the following approach to send mails from a specific Outlook account (IMAP, no Exchange Server). The code relies on an already opened outlook instance (but that can easily be changed)
Option Explicit
Public Enum oCreateMail
oSave = 1
oDisplay = 2
oSend = 4
End Enum
Public Sub RunSendMail()
Dim OutlookApp As Outlook.Application
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If OutlookApp Is Nothing Then
MsgBox "Please open Outlook first.", vbExclamation, "Open Outlook"
Exit Sub
End If
'load a template for your mail if necessary
Dim TemplateFile As String
TemplateFile = ThisWorkbook.Path & Application.PathSeparator & "template_message.msg"
'Name of Outlook account that should be used
Dim AccountName As String
AccountName = "account_1#acme.com"
Dim OutlookAccount As Outlook.Account
Set OutlookAccount = GetAccountByName(OutlookApp, AccountName)
If OutlookAccount Is Nothing Then
MsgBox "Outlook account '" & AccountName & "' was not found!", vbCritical, "Outlook Account"
Exit Sub
End If
'send a mail from a specific account
SendMail OutlookApp, OutlookAccount, "send_to#acme.com", oDisplay, "" 'use TemplateFile as template if you don't want to create the mail from scratch.
End Sub
Public Sub SendMail(ByVal OutlookApp As Outlook.Application, ByVal OutlookAccount As Outlook.Account, ByVal MailTo As String, Optional ByVal MailAction As oCreateMail = 2, Optional ByVal TemplateFile As String)
Dim NewMail As Outlook.MailItem
If TemplateFile <> vbNullString Then
Set NewMail = OutlookApp.CreateItemFromTemplate(TemplateFile)
Else
Set NewMail = OutlookApp.Createitem(0)
End If
With NewMail
.SendUsingAccount = OutlookAccount
'remove a automatically added signature if necessary
'RemoveAutoSignature NewMail
'new email from scratch
.HTMLBody = "test mail"
'alternatively replace something in the template:
'.HTMLBody = Replace$(.HTMLBody, "Placeholder", "Fill in TEXT")
.To = MailTo
Select Case MailAction
Case oDisplay
.Display
Case oSend
.Send
Case oSave
.Save
.Close olSave
End Select
End With
End Sub
Public Sub RemoveAutoSignature(ByRef Mail As Outlook.MailItem)
Dim oDocument As Word.Document
Set oDocument = Mail.GetInspector.WordEditor
Dim oBookmark As Word.Bookmark
Set oBookmark = oDocument.Bookmarks.Item("_MailAutoSig")
If Not oBookmark Is Nothing Then
oBookmark.Select
oDocument.Windows.Item(1).Selection.Delete
End If
End Sub
Public Function GetAccountByName(ByVal oApp As Outlook.Application, ByVal AccountName As String) As Outlook.Account
Dim oAccount As Outlook.Account
For Each oAccount In oApp.Session.Accounts
If oAccount.DisplayName = AccountName Then
Set GetAccountByName = oAccount
Exit For
End If
Next oAccount
End Function
The following can be used to list all available Outlook mail accounts:
Public Sub GetAllOutlookAccounts(ByVal oApp As Outlook.Application)
Dim oAccount As Outlook.Account
For Each oAccount In oApp.Session.Accounts
Debug.Print oAccount.DisplayName
Next oAccount
End Sub
Public Sub ListAllOutlookAccounts()
GetAllOutlookAccounts GetObject(, "Outlook.Application")
End Sub
I would like to extract the values in a drop-down field with the title "email address".
I would like the name selected to appear in the email "To" line.
I'm adding the ActiveDocument details to the subject line but would like to remove the .docx portion of the subject line.
Do I need separate Outlook code?
Sub RunAll()
Call Save
Call sendeMail
End Sub
Sub Save()
Dim strPath As String
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim oCC As ContentControl
strPath = "C:\Users\******x\Desktop\Test 4"
CreateFolders strPath
On Error GoTo err_Handler
Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the License plate number!"
oCC.Range.Select
GoTo lbl_Exit
Else
strPlate = oCC.Range.Text
End If
Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the Customer Name!"
oCC.Range.Select
GoTo lbl_Exit
Else
strName = oCC.Range.Text
End If
strFilename = strPlate & "__" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12
lbl_Exit:
Set oCC = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub
Private Sub CreateFolders(strPath As String)
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub
Private Sub sendeMail()
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String
strSubject = "VR*** Request: " + ActiveDocument + " CUSTOMER IS xx xx xx"
strBody = ""
strTo = ""
If ActiveDocument.FullName = "" Then
MsgBox "activedocument not saved, exiting"
Exit Sub
Else
If ActiveDocument.Saved = False Then
If MsgBox("Activedocument NOT saved, Proceed?", vbYesNo, "Error") <> vbYes Then Exit Sub
End If
End If
strAtt = ActiveDocument.FullName
Set olkApp = CreateObject("outlook.application")
With olkApp.createitem(0)
.To = strTo
.Subject = strSubject
.body = strBody
.attachments.Add strAtt
'.send
.Display
End With
Set olkApp = Nothing
End Sub
To get the doc's name without the extension, you can use this:
Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
InStrRev finds the last "dot" .
Left truncates the name until that position
-1 applied to the found position is to also remove the . itself
For example,
strSubject = "VR*** Request: " & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & " CUSTOMER IS xx xx xx"
Addendum
To get the email address from a content-control titled "email address", you can use this function:
Function getEmailAddress()
Dim sh As ContentControl
For Each sh In ThisDocument.Range.ContentControls
If sh.Title = "email address" Then
getEmailAddress = sh.Range.Text
Exit Function
End If
Next
End Function
i.e.
With olkApp.createitem(0)
.To = getEmailAddress
' etc...
I am trying to create a script that will add text to the subject of the email before it is forwarded. This is the first time I am writing one.
My criteria is set on the rule. The script will check the subject. Depending on the text in the subject it will add a certain text.
Example, the email I receive contains JobsDB in the subject then the text that should be added to the subject is Jobs DB. If the subject does not contains JobsDB then will go to next IF to check if it contains Indeed. If it does not it will go to another IF to check if it contains LinkedIn.
Current code:
Sub ForwardEmailIndeed(Item As Outlook.MailItem)
Set myForward = Item.Forward
If Item.Subject.Contains("Indeed") Then
myForward.Subject = Item.Subject & ("Indeed")
If Item.Body.Contains("s1JOBS") Then
myForward.Subject = Item.Subject & ("S1 Jobs")
If Item.Subject.Contains("JobsDB") Then
myForward.Subject = Item.Subject & ("JobsDB")
If Item.Subject.Contains("TradeWindsJobs") Then
myForward.Subject = Item.Subject & ("Tradewinds")
If Item.From.Contains("auto#oilandgasjobsearch.com") Or _
Item.Body.Contains("oilandgasjobsearch.com") Then
myForward.Subject = Item.Subject & ("Oil&Gas JobSearch")
If Item.From.Contains("LinkedIn") Or _
Item.Body.Contains("LinkedIn") Then
myForward.Subject = Item.Subject & ("Linkedin Advert")
End If
myForward.Recipients.Add "email#yahoo.com"
myForward.Send
End Sub
My rule works correctly but the script is not working.
This Code previously worked for me.
Sub ForwardEmail(Item As Outlook.MailItem)
Set myForward = Item.Forward
myForward.Subject = Item.Subject & (“Indeed”)
myForward.Recipients.Add “email#yahoo.com”
myForward.Send
End Sub
It does not work anymore. It does not forward anything.
You are looking for InStr not Contains.
http://msdn.microsoft.com/en-us/library/office/gg264811%28v=office.15%29.aspx
Option Explicit
Private Sub ForwardEmailIndeed_test()
' Open a mailitem first
Dim curritem As mailitem
Set curritem = ActiveInspector.currentItem
ForwardEmailIndeed curritem
End Sub
Sub ForwardEmailIndeed(Item As Outlook.mailitem)
Dim myForward As mailitem
Set myForward = Item.Forward
If InStr(Item.Subject, "Indeed") Then
myForward.Subject = Item.Subject & ("Indeed")
End If
If InStr(Item.body, "s1JOBS") Then
myForward.Subject = Item.Subject & ("S1 Jobs")
End If
If InStr(Item.Subject, "JobsDB") Then
myForward.Subject = Item.Subject & ("JobsDB")
End If
If InStr(Item.Subject, "TradeWindsJobs") Then
myForward.Subject = Item.Subject & ("Tradewinds")
End If
If InStr(Item.SenderEmailAddress, "auto#oilandgasjobsearch.com") Or _
InStr(Item.body, "oilandgasjobsearch.com") Then
myForward.Subject = Item.Subject & ("Oil&Gas JobSearch")
End If
If InStr(Item.SenderEmailAddress, "LinkedIn") Or _
InStr(Item.body, "LinkedIn") Then
myForward.Subject = Item.Subject & ("Linkedin Advert")
End If
myForward.Recipients.Add ("email#yahoo.com")
myForward.Send
End Sub
Private Sub ForwardEmail_test()
' Open a mailitem first
Dim curritem As mailitem
Set curritem = ActiveInspector.currentItem
ForwardEmailIndeed curritem
End Sub
Sub ForwardEmail(Item As Outlook.mailitem)
Dim myForward As mailitem
Set myForward = Item.Forward
myForward.Subject = Item.Subject & ("Indeed")
myForward.Recipients.Add ("email#yahoo.com")
myForward.Send
End Sub