Good Evening. I've been trying to transform a whole Word doc into a string. My current problem is that I can open the doc, select the text, but I can't manage to transform into a string. Funny thing is that a msgbox print the text on the screen.
Dim s_txt as string
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
s_arq = Cells(1, i_col)
Set wrdDoc = wrdApp.Documents.Open("C:\Users\USER\Desktop\TCC\pdf2doc\" & s_arq)
wrdApp.Selection.WholeStory
wrdApp.Selection.Find.ClearFormatting
MsgBox(wrdApp.Selection)
s_txt = wrdApp.Selection
wrdApp.Quit
When I try to get the string s_txt it returns nothing. But the msgbox print the text perfectly.
I tried selection.text, and it returns nothing.
Related
I'm using a macro in Excel to add information to a Word document. I'm trying to add 10 lines to an existing Word document like this:
Sub AddParagraphs()
'Open Word
Dim wordApp As Word.Application
Set wordApp = CreateObject("Word.Application")
'Open
Dim doc As Word.document
Set doc = wordApp.Documents.Open("c:\temp\document.docx")
'Add 10 paragraphs
Dim idx As Integer
For idx = 1 To 10
Dim paragraph As Word.paragraph
Set paragraph = doc.Paragraphs.Add()
paragraph.Range.style = wdStyleHeading2
paragraph.Range.text = "Paragraph " & CStr(idx)
Next
doc.Save
doc.Close
wordApp.Quit
End Sub
I have an empty Word document at C:\temp\document.docs but after running the code there is only one line with the text "Paragraph 10". I was expecting 10 lines.
As far as I can tell the Paragraphs.Add() with no arguments should create a new paragraph. Perhaps I'm mistaken to believe that a new paragraph produces a new line? Is there another way to add 10 lines in a loop where each can have a specific (not the same) style?
The "paragraph" that you are adding does not have a paragraph mark at the end.
Change that line to
paragraph.Range.Text = "Paragraph " & CStr(idx) & vbCr
and that should fix your problem.
Actually, what's happening in the original code is that you're always replacing the content when you use
Doc.Paragraphs.Add
So there's only ever the one paragraph. There are various ways to get around this. One is to use InsertAfter, as has been mentioned in comments. (Note that if you're going to use this, the correct way to specify a new paragraph as part of a string is vbCr or Chr(13). Word can very easily misinterpret anything else!)
My personal preference is to work with a Range object that can be manipulated independently of the entire document. For example, it can be done like this:
Sub AddParagraphs()
'Open Word
Dim wordApp As Word.Application
Set wordApp = CreateObject("Word.Application")
'Open
Dim doc As Word.document
Set doc = wordApp.Documents.Open("c:\temp\document.docx")
Dim rng as Word.Range
Set rng = doc.Content
'Add 10 paragraphs
Dim idx As Integer
For idx = 1 To 10
Dim paragraph As Word.paragraph
'So that the next thing inserted follows instead of replaces
rng.Collapse wdCollapseEnd
Set paragraph = rng.Paragraphs.Add
paragraph.Range.style = wdStyleHeading2
paragraph.Range.text = "Paragraph " & CStr(idx)
Next
doc.Save
doc.Close
wordApp.Quit
End Sub
I had a similar problem. Adding doc.Range.InsertParagraphAfter fixed my problems. The following code should work for you:
Sub AddParagraphs()
'Open Word
Dim wordApp As Word.Application
Set wordApp = CreateObject("Word.Application")
'Open
Dim doc As Word.document
Set doc = wordApp.Documents.Open("c:\temp\document.docx")
'Add 10 paragraphs
Dim idx As Integer
For idx = 1 To 10
Dim paragraph As Word.paragraph
Set paragraph = doc.Paragraphs.Add()
paragraph.Range.style = wdStyleHeading2
paragraph.Range.text = "Paragraph "
doc.Range.InsertParagraphAfter
Next
doc.Save
doc.Close
wordApp.Quit
End Sub
The Paragraphs.Add method appends a new paragraph consisting of the paragraph mark only at the end of the document. Oddly enough, the return value is not the now last paragraph but the penultimate paragraph. You get a reference to the new last paragraph by the Next method of the paragraph object. You can then set the style and insert text with the paragraph.Range.InsertBefore method.
The critical part of your code must be like this
'Add 10 paragraphs
Dim idx As Integer
Dim paragraph As word.paragraph
For idx = 1 To 10
Set paragraph = doc.Paragraphs.Add.Next
paragraph.Range.style = word.WdBuiltinStyle.wdStyleHeading2
paragraph.Range.InsertBefore "Paragraph " & CStr(idx)
Next
I need a VBA code to update my word file. It which consists of some tables That has to be updated from excel file. Excel file consists of bearing data with different bearing numbers. And my report has to be updated with the bearing values. Like for my next report if I just enter the different bearing file it must read all the bearing data from that file.
This has to be done in 3 steps. I have attached a sample image. firstly identify the bearing name which is always in A column (In this case I need to find (248_R), 38,7 % ). Then select 6*6 matrix data (suppose I find the bearing data to be in A946 then I need to record data from B950 to G955) and then transfer to word file(Only the values to the table). I am a newbee in VBA coding please can someone help?
image of sample bearing name with matrix underneath
Image of what the tables look like in the word document:
The first part of copying the range you want is relatively easy. You can use the following code to copy your desired matrix. I am not sure about pasting to a word document yet, give me some more time on that.
(For now, if you run this macro, the range you want will be copied. You can then switch to your word document and hit Ctrl+V to paste it into the desired table.
Also, please check and see whether the following references have been added:
Option Explicit
Sub findBearingDataAndPasteToWord()
Dim i As Integer
Dim aCell As Range, rng As Range
Dim SearchString As String
Set rng = Range("A750:A1790")
SearchString = "(248_R), 38,7 %"
For Each aCell In rng
If InStr(1, aCell.Value, SearchString, vbTextCompare) Then
ActiveSheet.Range(Cells(aCell.row + 4, 1), Cells(aCell.row + 9, 6)).Copy
Dim wrdApp As Word.Application
Dim docWd As Word.Document
MsgBox "Please select the word document that you want to paste the copied table data into (after pressing OK)" & _
vbNewLine & vbNewLine & "Script written by takanuva15 with help from Stack Overflow"
docFilename = Application.GetOpenFilename()
If docFilename = "False" Then Exit Sub
Set docWd = getDocument(docFilename)
Set wrdApp = docWd.Application
wrdApp.Selection.EndKey Unit:=wdStory
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.PasteExcelTable False, True, False
Exit Sub
Else: End If
Next aCell
End Sub
'Returns the document with the given filename
'If the document is already open, then it returns that document
Public Function getDocument(ByVal fullName As String) As Word.Document
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Dim fileName As String
Dim docReturn As Word.Document
fileName = Dir(fullName)
Set docReturn = Word.Documents(fileName)
If docReturn Is Nothing Then
Set docReturn = Word.Documents.Open(fullName)
End If
On Error GoTo 0
Set getDocument = docReturn
End Function
I have several word files. They are build like this
text
text
text
Name: Mick
Date: 1-1-1
text
text
Item: Item11 material: Gold
text
text
I am building a macro that can open a word file, put the name in Cell A1 and put the item in Cell A2. I have found a code on internet and adjusted it a little. The following code makes a selection from the beginning of the word doc until a word is found and copies that selection in a given cell.
I hope someone can show me how i can adjust this so the selection begins right before the needed value an stops after it
code below is for item:
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
Set wdDoc = .Documents.Open("path", False, True, False)
With wdDoc
Set wdRng = .Range(0, 0)
With .Range
With .Find
.Text = "material"
.Forward = True
.MatchWholeWord = True
.MatchCase = True
.Execute
End With
If .Find.found = True Then
wdRng.End = .Duplicate.Start
Sheets("sheet1").Range("A2").value = wdRng
End If
End With
.Close False
End With
.Quit
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
Anyone any suggestions?
Try the procedure below. It will open the specified Word document, parse the required values via Regular Expressions, place those values into cells A1 and A2, and then close the Word document.
When calling the procedure, specify the full path and filename of the Word document.
For example: SetNameAndItem "C:\Temp\Doc1.docx"
Public Sub SetNameAndItem(strPath As String)
Dim wdApp As Object: Set wdApp = CreateObject("Word.Application")
Dim wdDoc As Object: Set wdDoc = wdApp.Documents.Open(strPath, False, True, False)
Dim objRegEx As Object: Set objRegEx = CreateObject("VBScript.RegExp")
Dim objMatches As Object
On Error GoTo ProcError
With objRegEx
.Global = False
.MultiLine = True
.IgnoreCase = False
.Pattern = "^Name:\s(.*?)$"
End With
Set objMatches = objRegEx.Execute(wdDoc.Content)
If objMatches.Count = 0 Then
Debug.Print "Name: No match."
Else
Range("A1").Value = objMatches(0).SubMatches(0)
End If
objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
Set objMatches = objRegEx.Execute(wdDoc.Content)
If objMatches.Count = 0 Then
Debug.Print "Item: No match."
Else
Range("A2").Value = objMatches(0).SubMatches(0)
End If
ProcExit:
On Error Resume Next
wdDoc.Close False
wdApp.Quit
Set objMatches = Nothing
Set objRegEx = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Exit Sub
ProcError:
MsgBox "Error# " & Err.Number & vbCrLf & Err.Description, , "SetNameAndItem"
Resume ProcExit
End Sub
Result:
Note: Please ensure that the line breaks in your Word document consist of the normal Carriage Return / Line Feed character combination (the results of pressing pressing the Enter key). When I copied/pasted the text from your Question, the document looked as expected, but what appeared to be line feeds were actually Vertical Tab characters, so the Regular Expressions did not work. I'm not saying there was any error on your part, it's probably an artifact of pasting text the web page. Just something to be aware of.
UPDATE:
If the Regular Expressions in the above code don't work, then perhaps it was not a copy/paste issue after all, and you really do have Vertical Tab characters in your document. If that's the case, try modifying the SetNameAndItem procedure in the Excel VBA code as follows.
Replace these two lines (which use ^ and $ to represent start and end of line, respectively):
.Pattern = "^Name:\s(.*?)$"
objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
With these two lines (which use \v to represent vertical tab):
.Pattern = "\vName:\s(.*?)\v"
objRegEx.Pattern = "\vItem:\s(.*?)\smaterial"
Here is a possible solution of your problem:
Use this function to read the word file:
Option Explicit
Public Function f_my_story() as string
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
Set wdDoc = .Documents.Open("C:\Users\v\Desktop\text.docx", False, True, False)
f_my_story = wdDoc.Range(0, wdDoc.Range.End)
wdDoc.Close False
.Quit
End With
End Function
Once you have read the file, you get a string. Now you need a macro, which separates the string by space and it returns the values, that are after the values you are looking for.
You can write those values anywhere you want.
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
I'm trying to open two documents from excel with vba and call a word macro from this particular excel file.
The macro is working fine in Word and I also get the documents to open and the word macro to start. However when there is a switch from one document to the other the word macro goes to break-mode (which does not happen when I run it from Word instead of Excel).
I use the following code from excel:
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\Word Dummy's\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y
In word I have a sub with the parameters defined between breakets and the following code:
worddoc2 = "H:\Word Dummy's\texts.docx"
Word.Application.Activate
Documents.Open worddoc2, ReadOnly:=True
ThisDocument.Activate
Set bmks = ThisDocument.Bookmarks
Can anyone tell me why it does not run from excel and how I can fix this?
Thanks in advance.
I finally found the answer myself after a lot of searching on Google.
I needed to add :
application.EnableEvents=false
To the excel macro.
That was all. Now it works.
My complete code is huge (the macro in excel also opens two other workbooks and runs a macro in them). This part of the code is working for now (so I left it out), but I just want to add the part that it opens a worddoc and adds specific texts in it depending on what client has been chosen in the excel userform. But to show you a better idea how my code looks like, this is in excel (where the client is defined by a userform in another module):
Sub open_models (client as string)
Application.DisplayStatusBar = True
‘determine datatypes
Dim m_integer As Integer
Dim m_ultimo As String
Dim m_primo As String
Dim y As String
Dim y_integer As Integer
Dim y_old As String
Dim y_last As String
Dim wordApp As Object
Dim worddoc As String
'Determine current month and year and previous
m_integer = Format(Now, "mm")
y_integer = Format(Now, "yyyy")
If m_integer <= 9 Then
m_ultimo = "0" & m_integer - 1
m_primo = "0" & m_integer - 2
Else
m_ultimo = m_integer - 1
m_primo = m_integer - 2
End If
If m_integer = 1 Then
y = y_integer - 1
Else
y = y_integer
End If
On Error Resume Next
'open word dummy
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y, varg4:= worddoc)
On Error GoTo 0
ThisWorkbook.Activate
'reset statusbar and close this workbook
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ThisWorkbook.Close False
End Sub
And this is the code in word I am using:
Sub update_dummy(client As String, m_ultimo As String, y As String, worddoc as string)
Dim wordapp As Object
Dim rngStart As Range
Dim rngEnd As Range
Dim worddoc As String
Dim worddoc2 As String
Dim dekkingsgraad As String
Dim bmks As Bookmarks
Dim bmRange As Range
Dim rng As Range
Dim i As Boolean
On Error Resume Next
worddoc2 = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\dummytexts.docx"
'open other word
Documents.Open worddoc2, ReadOnly:=True
Documents(worddoc).Activate
Set bmks = Documents(worddoc).Bookmarks
'management summary
If client <> "PMT" Then
i = True
Set rngStart = Documents(worddoc2).Bookmarks("bn0_1_start").Range
Set rngEnd = Documents(worddoc2).Bookmarks("bn0_1_end").Range
End If
If i = True Then
Set rng = Documents(worddoc2).Range(rngStart.Start, rngEnd.End)
rng.Copy
Set bmRange = Documents(worddoc).Bookmarks("bmManagementsummary").Range
bmRange.PasteAndFormat (wdPasteDefault)
End If
i = False
On Error GoTo 0
End Sub
I have 20 more bookmarks that are defined but the code for them is all the same.
I have seen and solved this problem a few times before, the solution I found was odd.
Copy paste all your code into a text
editor, 1 for word, 1 for excel
Delete all the macros in word or excel or better yet, just create
new files.
Paste all the code into word/excel from your text editor.
I've definitely had this 3 or 4 times in Excel and Access. Especially if you previously had a breakpoint at that location.
It sounds stupid but try it and see if that works, this has saved me from insanity a few times.