Setting a range to current position in outlook VBA - vba

I have a macro that inserts a table into the active e-mail. Now my problem is that i cant figure out how to add the table where the user is typing when he runs the macro. I think I have to define a range, and I've looked into the collapse method but I'm stuck.
This is my code:
sub insertmytable() <br>
Dim oRng As Object <br>
Dim wdDoc As Object<br>
If TypeName(ActiveWindow) = "Inspector" Then<br>
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then<br>
Set wdDoc = ActiveInspector.WordEditor<br>
With wdDoc<br>
Set oRng = wdDoc.Range<br>
oRng.collapse<br>
.tables.Add Range:=oRng, numrows:=2, numcolumns:=5, defaulttablebehavior:=1, autofitbehavior:=0<br>
end with<br>
end if<br>
end if<br>
end sub<br>
Appreciate any help!

Try working with .InsertBefore
http://msdn.microsoft.com/en-us/library/dd492012(v=office.12).aspx
Sub PasteAtInsertionPoint()
Dim objOL As Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim strText As String
Set objOL = Outlook.Application
Set objDoc = objOL.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
strText = " Test"
objSel.InsertBefore strText
End Sub
Edit 2014 11 17
Sub insertmytable()
Dim oRng As Object
Dim wdDoc As Object
Dim objSel As Word.Selection
If TypeName(ActiveWindow) = "Inspector" Then
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
Set wdDoc = ActiveInspector.WordEditor
Set objSel = wdDoc.Windows(1).Selection
Set oRng = objSel.Range
oRng.Tables.Add Range:=oRng, NumRows:=2, NumColumns:=5, DefaultTableBehavior:=1, AutoFitBehavior:=0
End If
End If
End Sub

Related

Copy data from Word to Outlook body keeping formatting

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.

Setting Range based on Selection

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

Save email body to Word document

My goal is copy and past body of active email from Outlook to the MS Word, and save Word to specified destination.
Code
Dim objMail as Outlook.MailItem
Dim objWord As Object
Dim objDocument As Object
Dim objFSO As Object
Dim objTextStream As Object
Set objMail = Application.ActiveInspector.CurrentItem
Set objWord = CreateObject("Word.Application")
Set objDocument = objWord.Documents.Add
objMail.GetInspector().WordEditor.Range.FormattedText.Copy
objDocument.Range.Paste
Its a right way ?
You can check, if you really selected an email (either within the list or opened) and copy its formatted body like this:
Private Sub CopyEMailBodyToWord()
Dim objOutlook As Outlook.Application
Dim objMail As Object 'Outlook.MailItem, but has to be checked later
Dim objWord As Object
Dim objDocument As Object
Set objOutlook = Outlook.Application
Select Case TypeName(objOutlook.ActiveWindow)
Case "Explorer" ' get current item in list view
Set objMail = objOutlook.ActiveExplorer.Selection.Item(1)
Case "Inspector" ' get open item
Set objMail = objOutlook.ActiveInspector.CurrentItem
End Select
If objMail.Class = olMail Then
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then Set objWord = CreateObject("Word.Application")
Set objDocument = objWord.Documents.Add
' copy formatted body:
objMail.GetInspector.WordEditor.Range.FormattedText.Copy
objDocument.Range.Paste
' or copy text only:
'objDocument.Range.Text = objMail.Body
With objWord.FileDialog(msoFileDialogSaveAs)
.Title = "Save ..."
.InitialFileName = objWord.Options.DefaultFilePath(wdDocumentsPath) & _
"\" & objMail.Subject & ".docx"
If .Show <> False Then
objDocument.SaveAs _
FileName:=.SelectedItems(1), _
AddToMru:=False
End If
End With
End If
End Sub
Is this what you are trying to do?
Option Explicit
Public Sub Example()
Dim Email As Outlook.MailItem
Set Email = Application.ActiveInspector.CurrentItem
'Word document
Dim wdApp As Word.Application
Set wdApp = CreateObject("Word.Application")
Dim wdDoc As Word.Document
Set wdDoc = wdApp.Documents.Add
wdDoc.Activate
Dim wdRange As Word.Range
Set wdRange = wdDoc.Range(0, 0)
'Add email to the document
wdRange.Text = Email.Body
wdApp.Visible = True
wdDoc.SaveAs2 FileName:="C:\Temp\Example.docx", FileFormat:= _
wdFormatXMLDocument, CompatibilityMode:=15
End Sub
You may also wanna work with ActiveWindow.Class to avoid any error on your CurrentItem

Programmatically change properties in email body in Outlook with VBA

I have an email ready to be sent in Outlook 2013
I want to scan the body of the email for bold text (i.e., bold characters) and change its color to red
(nice to have) Exclude from the macro the signature
I put together the code below but still not working. Any ideas?
Public Sub FormatSelectedText()
Dim objItem As Object
Dim objInsp As Outlook.Inspector
' Add reference to Word library
' in VBA Editor, Tools, References
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
On Error Resume Next
'Reference the current Outlook item
Set objItem = Application.ActiveInspector.CurrentItem
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set objInsp = objItem.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
Set objChar = Characters.Selection
' replace the With block with your code
With objChar
' Formatting code goes here
'.Font.Size = 18
If .Font.Bold = True Then
.Font.Color = wdColorBlue
End If
.Font.Color = wdColorRed
'.Font.Italic = True
'.Font.Name = "Arial"
End With
For Each Char In Characters.Selection
If Char.Font.Bold Then
Char.Font.Color = RGB(0, 0, 255) 'TextRGBTmp
End If
Next Char
For Each Char In Characters.Selection
If Not Char.Font.Bold And Char.Font.Color = RGB(0, 0, 255) Then
Char.Font.Color = RGB(0, 0, 0)
End If
Next Char
End If
End If
End If
Set objItem = Nothing
Set objWord = Nothing
Set objSel = Nothing
Set objInsp = Nothing
End Sub
This is a follow up to question: Programmatically change font properties in email body
first of all: don't use On Error Resume Next when you're trying to debug your code. It makes your life harder.
second: use Option Explicit at the beginning of the module. With that option enabled, VBA will show you every variable that's not initialized (some bugs only occur from misspellings).
I've corrected your code, so it works for me:
Public Sub FormatSelectedText()
Dim objOutlook As Outlook.Application ' i used this because im working in MS Access
Dim objItem As Object
Dim objInsp As Outlook.Inspector
' Add reference to Word library
' in VBA Editor, Tools, References
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objChar As Object
Dim Char As Object
'Reference the current Outlook item
Set objOutlook = GetObject(, "Outlook.Application")
Set objItem = objOutlook.ActiveInspector.CurrentItem
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set objInsp = objItem.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
Set objChar = objSel.Characters ' this wasn't initialized
' replace the With block with your code
' With objChar ' you don't Need this block because objChar is an array and it throws an error when you try to use this code on the whole objChar object
' ' Formatting code goes here
' '.Font.Size = 18
' If .Font.Bold = True Then
' .Font.color = wdColorBlue
' End If
' .Font.color = wdColorRed
' '.Font.Italic = True
' '.Font.Name = "Arial"
' End With
For Each Char In objSel.Characters
If Char.Font.Bold Then
Char.Font.color = rgb(255, 0, 0) 'TextRGBTmp (the rgb was filled backwards, so the text became blue. i fixed it.
End If
Next Char
' the code of the second For Each was not neccessary.
End If
End If
End If
Set objItem = Nothing
Set objWord = Nothing
Set objSel = Nothing
Set objInsp = Nothing
End Sub

VBA Outlook How to add hyperlink into email body

This macro adds hyperlink to email :
Sub test_add_hyperlink()
Dim NewMail As Outlook.MailItem
Set NewMail = Application.ActiveInspector.CurrentItem
NewMail.HTMLBody = "<HTML><BODY><A href=http://www.someaddress.com>URL_TEXT</A></BODY></HTML>" & NewMail.HTMLBody End Sub
but how to add hyperlink in place where active cursor is ? I ask beacause I would like to add hyperlink not at the front of message, but where my currently writing message.
The hyperlink I would like to add is the hyperlink to file which is currently copied to Windows' clipboard, this part I've written, but I can't figure out how to place it not at the front of email, but in place where active cursor is. I think that macro based emulation of Windows' keypressing is one of the directions to follow.
This describes how to paste at the selection.
http://www.slipstick.com/developer/code-samples/paste-formatted-text-vba/
Sub PasteFormattedClipboard()
Dim objItem As Object
Dim objInsp As Outlook.Inspector
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Set objItem = Application.ActiveInspector.CurrentItem
Set objInsp = objItem.GetInspector
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
objSel.PasteAndFormat (wdFormatOriginalFormatting)
Set objItem = Nothing
Set objInsp = Nothing
Set objDoc = Nothing
Set objWord = Nothing
Set objSel = Nothing
End Sub
Sub InsertHyperlinkAtCursorPositon()
On Error GoTo finish
strLink = "http://www.outlookcode.com"
strLinkText = "Get Outlook code samples here"
Set objInsp = Application.ActiveInspector
Set objMsg = objInsp.CurrentItem
Set objDoc = objInsp.WordEditor
Set objSel = objDoc.Windows(1).Selection
If objMsg.BodyFormat <> olFormatPlain Then
objDoc.Hyperlinks.Add objSel.Range, strLink, _
"", "", strLinkText, ""
Else
objSel.InsertAfter strLink
End If
finish:
End Sub