I am using the following code to copy text and images from Microsoft Word and paste to the body of an Outlook e-mail. I am trying to exclude the first 4 lines from being copied (this code is copying everything in the document). How can I go about doing this?
Sub CopycontentintoOutlook()
Dim oMailItem As Object
Dim oWordApp As Object
Dim oWordDoc As Object
Dim oMailWordDoc As Object
Set oWordApp = CreateObject("Word.Application")
Set oWordDoc = ActiveDocument
oWordDoc.Content.Copy
Set oMailApp = CreateObject("Outlook.Application")
Set oMailItem = oMailApp.CreateItem(0)
With oMailItem
.To = "email"
.Subject = "This email contains Word-formatted text"
.Display
End With
Set oMailWordDoc = oMailApp.ActiveInspector.WordEditor
oMailWordDoc.Application.Selection.Paste
End Sub
I am also wondering if it is possible to use the text in the first line and set this as the email subject?
You can use the GoTo() function with the wdGoToLine value to set the insertion point to a specific line. From there, the MoveEnd() function can set the end of your selection to the end of your document.
' Set start to line 4...
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=4
' Select up to end of document...
Selection.MoveEnd Unit:=wdStory
Related
I am looking to create a via script in excel that will replace a text holder in a word doc with some text from excel.
I can get the via script to open the word doc, and then save the doc under a new name. however it will not execute the replace text part :(
Private Sub CommandButton1_Click()
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open("temp.docx")
With wdDoc.Content.Find
.ClearFormatting
.Text = "<<name>>"
With .Replacement
.ClearFormatting
.Font.Bold = True
.Text = "John Smith"
End With
.Execute Replace:=wdReplaceAll
End With
wdDoc.SaveAs2 Filename:=("temp2.docx")
Set wdApp = Nothing
Set wdDoc = Nothing
End Sub
I have tried doing a search in here but can't see where I am going wrong :(
currently it opens the word doc and saves it under a new name but does not replace the find and replace the text. Can anyone see where I have gone wrong and show me how to get it right?
When I set up a test for your problem description in Word, by typing <<name>> I see that Word replaces the two angled brackets with special symbols. And it offers the possibility to undo the AutoCorrect causing this.
Querying ASC(Selection.Text) on them gives Chr(171) and Chr(187), which are also double-angled bracket symbols, but using them in Find does not work. Querying AscW() reveals the two symbols are Unicode 8810 and 8811, so they need to be searched differently.
Assuming that's the issue in your case, the following works:
With wdDoc.content.Find
.ClearFormatting
.Text = ChrW(8810) & "name" & ChrW(8811) '"<<name>>"
With .Replacement
.ClearFormatting
.Font.Bold = True
.Text = "John Smith"
End With
.Execute Replace:=wdReplaceAll
End With
Further to your code - it has other, potentially grave problems (memory leak):
If you do this: wdApp.Visible = False then you need to be absolutely certain to remove Word from memory:
wdDoc.Close
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Unlike Excel, Word won't quit automatically when its object goes out of scope (macro ends). It will stay open, which you can see in the Task Manager.
In addition, you need to release the objects in the reverse order in which they were instantiated - wdDoc before wdApp.
Setup some DocVariables in your Word doc and run the code below, from within Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("BrokerFirstName").Value = Range("BrokerFirstName").Value
objWord.ActiveDocument.variables("BrokerLastName").Value = Range("BrokerLastName").Value
objWord.ActiveDocument.variables("Ryan").Value = Range("Ryan").Value
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
You can use essentially the same process by setting up Bookmarks in Word, and pushing data from fields in Excel to fields (Bookmarks) in Word.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
On Error Resume Next
ActiveDocument.Variables("BrokerFirstName").Value = Range("B1").Value
ActiveDocument.Variables("BrokerLastName").Value = Range("B2").Value
ActiveDocument.Fields.Update
On Error Resume Next
objWord.Visible = True
End Sub
The famouse hope - to have one button for all live cases with caption: "Make it OK!"
Do divide the task on parts:
- Get "... text from excel ..."
- "replace text in word doc ..." with text getted from Excel on previouse step
Do it by two separate procedures for each of tasks,
called from the third procedure united them.
.
I'm composing an email using VB.Net which is opened in Outlook 2013. I need to the contents to be displayed in its default font which is set by the user.
Now i need to get the default font and set to the email. When i tried it returns null at one place.
//Code:
Private m_valDefaultFontSpec As DefaultFont
Sub GetDefaultFontSpec(Optional blnGetReplyFont As Boolean = False)
Dim objDoc As Document
Dim rng As Range
Dim objDummy As MailItem
On Error Resume Next
' Create a "dummy" mail object,
Set objDummy = Application.CreateItem(olMailItem)
' Get the document object from the current "dummy mail" object.
Set objDoc = objDummy.GetInspector.WordEditor //returns nothing here
' Get the range of the word document object.
Set rng = objDoc.Range
' Get some font properties from the given range.
With rng
m_valDefaultFontSpec.Name = .Font.Name
m_valDefaultFontSpec.Size = .Font.Size
m_valDefaultFontSpec.Bold = .Font.Bold
m_valDefaultFontSpec.Color = .Font.Color
m_valDefaultFontSpec.Italic = .Font.Italic
End With
' Finished with the "dummy" mail, close it.
objDummy.Close olDiscard
On Error GoTo 0
End Sub
Where am i wrong? Any help?
Source
WordEditor property might not be available until the message is shown.
Try to simply set the MailItem.HTMLBody property.
I'm trying to create a macro to look for to specific expressions and remove that content.
For example I need to remove everything that goes from the word "NOTIFICATION" to the expression "Good Morning" (but keeping "Good Morning, if possible).
I have a code to remove one line, but cannot figure out how to do it with a selection, because I don't have the same number of lines every time. Could be 3 or up to 9, more or less.
The code I have is like this (I've removed the parts of the code that did other things that are not related to this problem I have):
Private Sub ProcessMsg(msg As MailItem)
On Error GoTo ErrorHandlerProcessMsg
Dim msg2 As Outlook.MailItem
Dim msgDoc As Word.Document
Dim msgDoc2 As Word.Document
Dim objSel As Word.Selection
Set msg2 = Application.CreateItem(olMailItem)
Set msgDoc = msg.GetInspector.WordEditor
Set msgDoc2 = msg2.GetInspector.WordEditor
msgDoc.Select
msgDoc.Windows(1).Selection.Copy
msgDoc2.Windows(1).Selection.PasteAndFormat wdPasteDefault
Set objSel = msgDoc2.Windows(1).Selection
With objSel
.Find.Execute "NOTIFICATION"
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdStory, 1
.Delete
End With
Set objSel = msgDoc2.Windows(1).Selection
With objSel
.MoveStart WdUnits.wdStory, -1
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdParagraph, 1
.Delete
End With
Set msgDoc = Nothing
Set msgDoc2 = Nothing
Set objSel = Nothing
Set msg2 = Nothing
Exit Sub
ErrorHandlerProcessMsg:
Set msgDoc = Nothing
Set msgDoc2 = Nothing
Set objSel = Nothing
Set msg2 = Nothing
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Could anyone enlighten me?
This does what you want (from what I understand). Just paste this function inside one of the word document's code objects and run it (have tried on Word, rather than Excel). It's mainly to show you how you could go by handling such a problem.
Sub LineRemover()
Dim doc As Document
Set doc = ActiveDocument
Dim myParagraph As Paragraph
Dim mySentences As Sentences
Dim mySentence As Range
Dim deleted As Boolean
deleted = False
For Each myParagraph In doc.Paragraphs
Set mySentences = myParagraph.Range.Sentences
For Each mySentence In mySentences
If InStr(mySentence, "Good morning") <> 0 Then
'"Good morning" is present inside this line; exit the loop!
Exit For
ElseIf deleted Then
'"NOTIFICATION" was already deleted, need to remove all subsequent lines!
mySentence.Delete
ElseIf InStr(mySentence, "NOTIFICATION") <> 0 Then
'"NOTIFICATION" is present inside this line; delete it!
mySentence.Delete
deleted = True 'Tell the program you've deleted it!
End If
Next
If deleted Then
Exit For
End If
Next
End Sub
Extra details : InStr(String1, String2) will return the position at which String2 is found inside String1
I would like to grab a running word application and insert some text.
The VBA/Macro code is run from another separate Microsoft application such as Word or Excel. Is this possible?
It is quite easy. You need just this simple code to put inside any Excel, PP, Outlook Module. To catch Word from Word... you don't need it, you are just in.
Sub catch_word()
Dim WRD As Object
On Error Resume Next
Set WRD = GetObject(, "Word.Application")
If WRD Is Nothing Then
MsgBox "Word Application is not open"
Else
'add new document and add text into it
Dim DOC
Set DOC = WRD.documents.Add
DOC.Content.Text = "First text into document"
End If
End Sub
Edit If you know the name of the document which is already opened you could go this simply way to catch it and put some text into it:
Sub catch_word_document()
Dim WRD As Object
On Error Resume Next
Set WRD = GetObject("Document1")
If WRD Is Nothing Then
MsgBox "Word Application is not open"
Else
'add text into it
WRD.Content.Text = "First text into document"
End If
End Sub
Thanks KazJaw.
How ever, I want to add text to the opened Word document and not add another.
Based on your code
Sub catch_word()
Dim WRD As Object
Dim WRD_WINDOWS As Object
Dim strTemp As String
On Error Resume Next
Set WRD = GetObject(, "Word.Application")
If WRD Is Nothing Then
MsgBox "Word Application is not open"
Else
Set WRD_WINDOWS = WRD.Windows
For Each win In WRD_WINDOWS
If (win.Document.FullName = "Document1") Then
win.Document.Range(Start:=125, End:=134).Text = "Some Text"
strTemp = win.Document.Range(Start:=5, End:=10).Text
End If
Next
End If
The task is to apply strikeout to current font in selected text area.
The difficulty is that Outlook doesn't support recording macros on the fly - it wants code to be written by hand.
For example, the following simple code:
Selection.Font.Strikethrough = True
works for Word, but gives an error for Outlook:
Run-time error '424':
Object required
This assumes that you also have Word installed on your box. If so, you can access most of the Word OM from the Outlook VBE without referencing Word by using the ActiveInspector.WordEditor object.
Sub StrikeThroughinMailItem()
Dim objOL As Application
Dim objDoc As Object
Dim objSel As Object
Set objOL = Application
Set objDoc = objOL.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
objSel.Font.Strikethrough = True
End Sub
Here are a few notes on messing around with the open message, there are no checks, it just assumes that you have an open mail item. If you would like to say a little more about what you want to do, and in what version, I may be able to help a little more.
Dim ActiveMessage As MailItem
Dim strHTML As String
Set ActiveMessage = ActiveInspector.CurrentItem
Debug.Print ActiveMessage.Body
Debug.Print ActiveMessage.HTMLBody
strHTML = Replace(ActiveMessage.Body, "This sentence is bold", _
"<STRONG>This sentence is bold</STRONG>")
ActiveMessage.HTMLBody = strHTML
Debug.Print ActiveMessage.HTMLBody
You need to access the Inspector's HTMLEditor or WordEditor. Check the help file for sample code. If you are using WordEditor then you can record macro in Word and incorporate the resultant code into the Outlook macro by using the WordEditor.
Public Sub DoIt()
'must set word as mail editor
'must set reference to word object library
Dim oInspector As Outlook.Inspector
Dim oDoc As Word.Document
Dim oItem As Outlook.MailItem
Set oItem = Outlook.Application.CreateItem(olMailItem)
oItem.BodyFormat = olFormatRichText 'must set, unless default is rich text
Set oInspector = oItem.GetInspector
oInspector.Display 'must display in order for selection to work
Set oDoc = oInspector.WordEditor
'better to use word document instead of selection
'this sample uses selection because word's macro recording using the selection object
Dim oSelection As Word.Selection
Set oSelection = oDoc.Application.Selection
oSelection.TypeText Text:="The task is to apply strikethroughout."
oSelection.MoveLeft Unit:=wdCharacter, Count:=4
oSelection.MoveLeft Unit:=wdCharacter, Count:=7, Extend:=wdExtend
oSelection.Font.Strikethrough = True
End Sub
Jumping off from Todd Main's excellent example above.
I slightly modified the code to work in the inline reply pane as we couldn't find a simple way to add strikethrough to the QAT or ribbon.
I also added an if block to toggle the strikethrough if it was already set.
Sub StrikeThroughinInlineReply()
Dim objOL As Application
Dim objDoc As Object
Dim objSel As Object
Set objOL = Application
Set objDoc = objOL.ActiveExplorer.ActiveInlineResponseWordEditor
Set objSel = objDoc.Windows(1).Selection
If objSel.Font.Strikethrough = False Then
objSel.Font.Strikethrough = True
Else
objSel.Font.Strikethrough = False
End If
End Sub