Is it possible to copy the text you have selected in a mailbody to a variable
eg
Sub cpytxt()
Set txt = Selection
'Do something
End Sub
Crédits: gmayor, Source/Fonte: http://www.vbaexpress.com/forum/showthread.php?52985-VBA-get-selected-text-from-Outlook-email-body-and-use-in-Excel
Public Sub ShowTextSelected()
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim strText As String
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
MsgBox strText
lbl_Exit:
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Exit Sub
End Sub
Related
Below coding is working fine to send an email with the excel range. Just wanted to all "Hello**" at the top of the email Body (Left alignment). Please assist.
Dim OutApp As Object, OutMail As Object
Dim wdDoc As Object, wdRange As Object
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.Sheets("Certificate").Range("A1:O36")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.Subject = "Subject"
.Display
Set wdDoc = .GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
rng.Copy
wdRange.Paste
DoEvents
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
'wdRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
For i = 1 To wdRange.Tables.Count
wdRange.Tables(i).Rows.Alignment = wdAlignRowCenter
Next i
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try the next way, please:
Sub sendOutlookMail()
Dim OutApp As Object, OutMail As Object
Dim wdDoc As Object, wdRange As Object
Dim rng As Range, i As Long
Set rng = ThisWorkbook.Sheets("Certificate").Range("A1:O36")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.subject = "Subject"
.display
Set wdDoc = .GetInspector.WordEditor
With wdDoc
.Paragraphs(1).Range.InsertAfter ("Hello!" & vbCrLf)
rng.Copy
.Paragraphs(2).Range.Paste
End With
End With
End Sub
I am trying to copy data from a Word document to an Outlook body while keeping formatting. My code pastes the data but loses formatting.
I tried GetInspector.WordEditor. I get an error 287 (Application defined or object defined error).
Sub openword()
Dim wdapp As Object
Dim wddoc As Object
Dim olapp As Object
Dim olmail As Object
Dim myemail As Variant
Dim str As String
Set wdapp = CreateObject("Word.Application")
Set wddoc = wdapp.Documents.Open("C:\Users\Ankit.Pandey\Desktop\Templates\DR.docx", ReadOnly:=True)
Set olapp = CreateObject("Outlook.Application")
Set olmail = olapp.CreateItem(olMailItem)
With olmail
.Display
.To = "a"
.CC = "b"
.Subject = "This is a test mail"
.Body = wddoc.Range
End With
Set olapp = Nothing
Set wdapp = Nothing
wddoc.Close
End Sub
This should work, I think
Sub openword()
Dim wdapp As Object
Dim wddoc As Object
Dim olapp As Object
Dim olmail As Object
Dim myemail As Variant
Dim str As String
'************** Code edited here
Dim olInspector As Object
Dim olWordEditor As Object
'**************
Set wdapp = CreateObject("Word.Application")
Set wddoc = wdapp.Documents.Open("C:\Users\Ankit.Pandey\Desktop\Templates\DR.docx", ReadOnly:=True)
Set olapp = CreateObject("Outlook.Application")
Set olmail = olapp.CreateItem(olMailItem)
With olmail
.Display
.To = "a"
.CC = "b"
.Subject = "This is a test mail"
'************** Code edited here
'.Body = wddoc.Range
Set olInspector = .GetInspector
Set olWordEditor = olInspector.WordEditor
wddoc.Range.Copy
olWordEditor.Range(0, 0).Paste
'*************
End With
Set olapp = Nothing
Set wdapp = Nothing
wddoc.Close
End Sub
Copying and pasting should keep the formatting. Use Range(0, 0).Paste rather than Selection.Paste to prserve anything that is already there such as your signature.
I'm trying to set up a form so that when a subject - in the example I have, it's animals - is selected from a ComboBox, it changes both the file name and also the subject line of the email. Currently, it just sends an email when you click the submit button, but I need to differentiate between files depending on which subject is selected. I've tried searching for an answer, but I've so far not come across anything related.
The ComboBox has four entries in it. Tiger, Monkey, Elephant, Giraffe.
The ComboBox is named "Animals" and it's tag is "ComboBox1"
Unfortunately, for whatever reason, I am unable to upload a picture, but it is a "Combo Box Content Control" if that helps. Apologies, I have limited knowledge of this stuff, it's mostly been trial and error to get me to this point and borrowing other pieces of code.
Any suggestions would be helpful.
Private Sub Submit_Click()
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objInspector As Object
Dim objDoc As Word.Document
Dim objRange As Range
Dim sDocname As String
ActiveDocument.Save
sDocname = ActiveDocument.FullName
If Len(ActiveDocument.Path) = 0 Then
MsgBox "Document is not saved!"
GoTo lbl_Exit
End If
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err <> 0 Then
MsgBox "Outlook is not running."
GoTo lbl_Exit
End If
On Error GoTo 0
Set objOutlookMsg = objOutlook.createitem(0)
With objOutlookMsg
.To = "email#emailaddress.com"
.Cc = ""
.Subject = "Favourite Animal is "
.attachments.Add sDocname
Set objInspector = .GetInspector
Set objDoc = objInspector.WordEditor
Set objRange = objDoc.Range(0, 0)
.Display
objRange.Text = "My favourite animal is the "
.Send
End With
lbl_Exit:
Set objDoc = Nothing
Set objRange = Nothing
Set objOutlookMsg = Nothing
Set objInspector = Nothing
Set objOutlook = Nothing
Exit Sub
End Sub
What about something like this?
Private Sub Submit_Click()
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objInspector As Object
Dim objDoc As Word.Document
Dim objRange As Range
Dim sDocname As String
'new declarations.
Dim cmb As ContentControl
Dim sSelText As String
'get a reference of the combobox.
Set cmb = ThisDocument.SelectContentControlsByTag("Combobox1")(1)
'get the selected item in a variable.
sSelText = cmb.Range.Text
Set cmb = Nothing
'enforce making a selection.
If sSelText = "DEFAULT_TXT" Then 'write here the default text of your combobox.
MsgBox "Please select subject from the dropdown menu.", vbCritical, "No selection!"
Else
ActiveDocument.Save
sDocname = ActiveDocument.FullName
If Len(ActiveDocument.Path) = 0 Then
MsgBox "Document is not saved!", vbCritical, "Error!"
GoTo lbl_Exit
End If
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err <> 0 Then
MsgBox "Outlook is not running."
GoTo lbl_Exit
End If
On Error GoTo 0
Set objOutlookMsg = objOutlook.createitem(0)
With objOutlookMsg 'use the selected item as you wish.
.To = "email#emailaddress.com"
.Cc = ""
.Subject = "Favourite Animal is " & sSelText
.attachments.Add sDocname & "_" & sSelText
Set objInspector = .GetInspector
Set objDoc = objInspector.WordEditor
Set objRange = objDoc.Range(0, 0)
.Display
objRange.Text = "My favourite animal is the " & sSelText
.Send
End With
End If
lbl_Exit:
Set objDoc = Nothing
Set objRange = Nothing
Set objOutlookMsg = Nothing
Set objInspector = Nothing
Set objOutlook = Nothing
End Sub
I want to take a reference number in an email to highlight and replace with a direct link to web page.
The current code will place the new hyperlink at the start of the email instead of the selected areas (currently wddoc.Range(0 , 0)).
If I use Selection it says the variable is undefined by user.
Sub AddHyperlink()
Dim olEmail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim oRng As Object
Dim strLink As String
Dim strLinkText As String
Dim OutApp As Object
Dim OutMail As Object
Dim strText As String
On Error Resume Next
'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
'Outlook wasn't running, so cancel
If Err <> 0 Then
MsgBox "Outlook is not running so nothing can be selected!"
GoTo lbl_Exit
End If
On Error GoTo 0
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)
With OutMail
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
strText = wdDoc.Application.Selection.Range.Text
End With
strLink = "http://website.com/#" & strText & "" ' the link address
strLinkText = "" & strText & "" ' the link display text
On Error Resume Next
Set olEmail = ActiveInspector.CurrentItem
With olEmail
.BodyFormat = olFormatHTML
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0) '!!!Cannot find something that replaces range with current selection!!!!
oRng.Collapse 0
Set oLink = wdDoc.Hyperlinks.Add(Anchor:=oRng, _
Address:=strLink, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=strLinkText)
Set oRng = oLink.Range
oRng.Collapse 0
.Display
End With
lbl_Exit:
Exit Sub
End Sub
When I have a new email open in MS Outlook, I'll have a keyboard shortcut setup to run the code in VBA within Outlook.
Outlook vba while working with ActiveInspector, try the following.
Option Explicit
Public Sub Example()
Dim wdDoc As Word.Document
Dim rngSel As Word.selection
If Application.ActiveInspector.EditorType = olEditorWord Then
Set wdDoc = Application.ActiveInspector.WordEditor ' use WordEditor
Set rngSel = wdDoc.Windows(1).selection ' Current selection
wdDoc.Hyperlinks.Add rngSel.Range, _
Address:="U:\plot.log", TextToDisplay:="Here is the link"
End If
Set wdDoc = Nothing
End Sub
I have written code to download an attachment to a specified folder.
Const olFolderInbox = 6
Sub detectpp_plate_record1()
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")
' File_Path = "D:\Attach\"
File_Path = "C:\Users\Desktop\pocket setter excel\"
If unRead.Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
For Each m In unRead
If m.Attachments.Count > 0 Then
For Each att In m.Attachments
If att.Filename Like "plate record*" Then
MsgBox "Unread Email with attachment available In Inbox"
'Like "plate record*.xls"
'~~> Download the attachment
' to the file path and file name
'att.Filename = name of attachement
att.SaveAsFile File_Path & "plate record"
'att.SaveAsFile File_Path & att.Filename
'& Format(plate record)
' mark attachment as read
m.unRead = False
DoEvents
m.Save
WorkFile = Dir(File_Path & "*")
Do While WorkFile <> ""
If Right(WorkFile, 4) <> "xlsm" Then
Workbooks.Open Filename:=File_Path & WorkFile
ActiveWorkbook.SaveAs Filename:= _
File_Path & WorkFile & "", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close
Kill File_Path & WorkFile
End If
WorkFile = Dir()
Loop
Exit Sub
End If
Next att
End If
Next m
End If
End Sub
The problem : This can be executed only when Outlook is open.
Therefore I have to separately open Outlook.
My requirement is to use Excel VBA code to detect if Outlook is open, if it is not, then it should be opened.
---------------------UDATE-----------------------
I combined the above code with the following code.
#Const LateBind = True
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
Sub detectpp_plate_record()
MyMacroThatUseOutlook
detectpp_plate_record1
End Sub
#If LateBind Then
Public Function OutlookApp( _
Optional WindowState As Long = olMinimized, _
Optional ReleaseIt As Boolean = False _
) As Object
Static oOutlook As Object
#Else
Public Function OutlookApp( _
Optional WindowState As Outlook.OlWindowState = olMinimized, _
Optional ReleaseIt As Boolean _
) As Outlook.Application
Static oOutlook As Outlook.Application
#End If
On Error GoTo ErrHandler
Select Case True
Case oOutlook Is Nothing, Len(oOutlook.name) = 0
Set oOutlook = GetObject(, "Outlook.Application")
If oOutlook.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
oOutlook.Session.GetDefaultFolder(olFolderInbox).Display
oOutlook.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set oOutlook = Nothing
End Select
Set OutlookApp = oOutlook
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set oOutlook = Nothing
Case 429, 462
Set oOutlook = GetOutlookApp()
If oOutlook Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Sub MyMacroThatUseOutlook()
Dim OutApp As Object
Set OutApp = OutlookApp()
'Automate OutApp as desired
End Sub
Now, if Outlook is open the code searches for the specified unread email.
If Outlook is closed, it opens it, but afterwards there is an error
Run time error 429:
ActiveX component cant create object.
Therefore once again I have to click on button for the code to search for the specified emails.
How do I get rid of this error and perform this in one go?
Add this to your code:
Dim oOutlook As object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error Goto 0
If oOutlook Is Nothing Then
Set oOutlook = CreateObject("Outlook.Application")
End If
I tried and tested it . It works.
Something like this:-
Set oOutlook = GetObject(, "Outlook.application")
If oOutlook is nothing Then
'outlook is not running so start it
set oOutlook = New Outlook.Application
Else
' outlook is running
End If