Can not copy from Excel and paste to a Form Edit restricted Word document unless restriction is turned off - vba

I am copying Excel cell contents to a bookmark on a Form Edit restricted (2010) Word document but it will only paste if the protection is turned off.
The code I currently have to turn the protection on again afterwards errors. What is the correct code?
Is there a way to make this copy and paste without turning off the protection?
Second problem is that when the text is pasted to the bookmark the font is Red (if manually entered on the document it is in black). The Word default is set as black (I reset the default for good measure). Typing in a new document is in black, however, when Word opens the font icon shows red even though checking the default it is still shows black. Can I define the font colour in the VBA to override this issue until is is resolved or can you suggest a way to fix the Word default?
Sub Arzbericht_Brandstetter()
' x - Defined Cell Names - ARTBrandPATH , ARTBrandDOC
' Excel Word Bookmark
' x - Defined Cell Names - ARZKrankenhaus Text65
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Dim Wd As Object
Dim wdDoc As Object
Dim BrandstetterDoc As Object
Dim BrandstetterPath As String
Dim f As Boolean
BrandstetterPath = ActiveSheet.Range("ARTBrandPATH").Value & ActiveSheet.Range("ARTBrandDOC").Value & ".doc" ' x
' On Error Resume Next
Set BrandstetterDoc = GetObject(BrandstetterPath)
If BrandstetterDoc Is Nothing Then
Set Wd = GetObject(, "Word.Application")
If Wd Is Nothing Then
Set Wd = CreateObject("Word.Application")
If Wd Is Nothing Then
MsgBox "Failed to start Word!", vbCritical
Exit Sub
End If
f = True
End If
Set BrandstetterDoc = Wd.Documents.Open(BrandstetterPath)
If BrandstetterDoc Is Nothing Then
MsgBox "Failed to open Brandstetter Document!" & vbNewLine & _
" Check File Directory is correct", vbCritical
If f Then
Wd.Quit
End If
Exit Sub
End If
Wd.Visible = True
Else
With BrandstetterDoc.Parent
.Visible = True
.Activate
' Turn Protection OFF
With ActiveDocument
.Unprotect "xxxxx"
.Protect wdAllowOnlyRevisions, , Password:="xxxxx"
End With
BrandstetterDoc.Bookmarks("Text65").Range.Text = ws.Range("ARZKrankenhaus").Value
' Turn Protection ON (Restricted Editing)
' ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
End With
End If
End Sub

Because its a Formfield and not just a bookmark I changing the code as below which resolved the strange red font issue. I can now copy to the document protected.
From
BrandstetterDoc.Bookmarks("Text65").Range.Text = ws.Range("ARZKrankenhaus").Value
To
ActiveDocument.FormFields("Text65").Result = ws.Range("ARZKrankenhaus").Value

Related

Copy table from Word and paste into another Word document

I'm trying to open a Word Document and copy the whole table inside it and then paste it into another already-open document after a specific heading/bookmark (that I have bookmarked in the document). Then finally prompt the user to save the document with the newly pasted table.
Examples seen online are Excel-to-Word or Word-to-Excel; I need Word-to-Word.
I'm able to pull up the first document (I think it successfully copies it, too--I haven't tested it), but when it activates the second document, it stops and gives an error that it doesn't have an object assigned.
The debugger highlights Set WrdRng = Active.Bookmarks("AppendixA").Range.
Sub TEST()
'
' Declare Table Document Var as Object
Dim tb As Object
Dim bk As Bookmark
Dim WrdRng As Range
'
'
'Set up Word Application
Set tb = CreateObject("Word.Application")
tb.Visible = True
'Opens Pre-Saved Document & activates it to use
tb.Documents.Open "C:\ Desktop\Table.dotm"
tb.Activate
Selection.WholeStory
'ActiveDocument.Tables(1).Select
Selection.Font.Name = "Calibri"
Selection.Copy
'Activate Rolling Trend Report Document and Paste
Windows("TEST - Compatibility Mode").Activate
' where the error occurs and the debugger highlights
Set WrdRng = Active.Bookmarks("AppendixA").Range
'Paste to Bookmark
With WrdRng
Selection.InsertAfter
End With
'Save Completed Report to Desktop
ChangeFileOpenDirectory "C: \Desktop\"
ActiveDocument.SaveAs2 FileName:="TEST.docm", _
FileFormat:=wdFormatXMLDocumentMacroEnabled
'
'
'
End Sub
Your code is failing because Set WrdRng = Active.Bookmarks("AppendixA").Range should be Set WrdRng = ActiveDocument.Bookmarks("AppendixA").Range
However, your code is badly written, will also fail in other places and will create an extra instance of Word.
The code below is to run from Word
Sub TEST()
'store a pointer to the document you wnat to insert table into
'assumed to be currently active document
Dim targetDoc As Document
Set targetDoc = ActiveDocument
'Open Pre-Saved Document
Dim tblDoc As Document
Set tblDoc = Documents.Open("C:\ Desktop\Table.dotm")
Dim source As Range
Set source = tblDoc.Content
'exclude the paragraph that comes after the table
source.MoveEnd Unit:=wdCharacter, Count:=-1
source.Font.Name = "Calibri"
Dim appxA As Range
Set appxA = targetDoc.Bookmarks("AppendixA").Range
appxA.Collapse wdCollapseEnd
'transfer the text and close the source document
appxA.FormattedText = source.FormattedText
tblDoc.Close wdDoNotSaveChanges
'it is necessary to pass the full file path to the SaveAs command
ActiveDocument.SaveAs2 FileName:="C: \Desktop\TEST.docm", _
FileFormat:=wdFormatXMLDocumentMacroEnabled
End Sub

Check if Word document closed from Excel VBA

I'm performing several prints of embedded Word document witch has some fields linked to some cells, by my PrintOut macro, in a For..Next loop, as below.
I need after each print task, that the program wait for document to close and then doing the next print.
In this situation I receive error. Can anyone help ?
Sub contract()
Dim i As Integer
For i = 1 To 100
Cells(Sheets("SheetName").ListObjects("StaffInfo").ListRows.Count + 9, 8).Value = i
General.PrintIt ("EmbeddedDoc") 'Doc has many linked fields
Next i
End Sub
Print method
Sub PrintIt(P As String)
Dim objWord As Object
Dim ObjDoc As Object
Dim Oshp As Object
Application.ScreenUpdating = False
ActiveSheet.OLEObjects(P).Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set ObjDoc = objWord.ActiveDocument
ObjDoc.Fields.Update
For Each Oshp In ObjDoc.Content.ShapeRange
Oshp.TextFrame.TextRange.Fields.Update
Next
ObjDoc.PrintOut Background:=False
ObjDoc.PrintOut
objWord.Quit SaveChanges:=False
Application.ScreenUpdating = True
End Sub 'Print it
Introduced problem was solved by this code.
Above code do open and close embedded word document, 100 times, and that problem was happening in close document.
Exactly, I cant understand why closing document immediately after printout command that where after open and update fields, generating that error.
Thus I cleaned the problem ask!
By integrating "PrintIt" method in "Contract" method that is parent of that, without calling "PrintIt" for each document printout, embedded document opens each one, perform doc links updating and printing 100 times in for next loop and close word app and document, at last, each one too.
In short, I cant find reason of problem in several Open-Print-Close document in order immediately; But i change the algorithm to Open-Several print-Close and problem been cleaned!
Sub contract()
Application.ScreenUpdating = False
Sheets("SheetName").Unprotect
'Declare variables
Dim i As Integer
Dim objWord, ObjDoc As Object
'Core
ActiveSheet.OLEObjects("Contract").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set ObjDoc = objWord.ActiveDocument
For i = 1 To 100
Cells(x, y).Value = i 'A specific cell that
' word embedded document fields are linked to
'corresponding fields they values change
'by changing this cell.
ObjDoc.Fields.Update
ObjDoc.PrintOut Background:=False
ObjDoc.PrintOut
Next i
objWord.Quit SaveChanges:=False
Sheets("SheetName").Protect AllowFiltering:=True
End Sub

Copy and paste on new page

I am trying to write a code that copies the contents of multiple worksheets in a single workbook into a single word document. I want the content of each worksheet to be on its own page, but right now, my code is just copying and pasting over each other instead of going onto a new page and pasting. I've tried going to the end of the document but it isn't working... Any advice would be helpful.
Sub ToWord()
Dim ws As Worksheet
Dim Wkbk1 As Workbook
Set Wkbk1 = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A1:A2").Copy
Dim wdapp As Object
Dim wddoc As Object
Dim Header As Range
Dim strdocname As String
'file name & folder path
On Error Resume Next
'error number 429
Set wdapp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'create new instance of word application
Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
'define paths to file
strdocname = "C:\Doc.doc"
If Dir(strdocname) = "" Then
MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "C:\Doc.doc", vbExclamation, "The document does not exist "
Exit Sub
End If
wdapp.Activate
Set wddoc = wdapp.Documents(strdocname)
If wddoc Is Nothing Then Set wddoc = wdapp.Documents.Open(strdocname)
'must activate to be able to paste
wddoc.Activate
wddoc.Range.Paste
Next ws
'Clean up
Set wddoc = Nothing
Set wdapp = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
you can just use:
wddoc.Range(i).Paste
incrementing i by 1 after each image. that pastes them one after another.
or more simply:
wddoc.Range(wddoc.Characters.Count-1).Paste
then could get more complicated and add a page break manually in between each if images are small to ensure a new page for each:
wddoc.Range(wddoc.Characters.Count-1).InsertBreak Type:=7
https://msdn.microsoft.com/en-us/library/office/ff821608.aspx
EDIT
First, I incorrectly assumed the "wddoc.range" property would get wherever the cursor is. This is not true. You need to use the code provided by Miss Palmer (and replicated below).
However, there is an additional issue I didn't notice at first. Your loop is set incorrectly. You are looping through and continually reopening the word doc. You need to move these lines:
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A1:A2").Copy
so that they are immediately above the
wddoc.Range(wddoc.Characters.Count - 1).Paste
line. This will cause the loop to be executed properly and only open the word doc once.
Also (again, per Miss Palmer), you want to put this:
wddoc.Range(wddoc.Characters.Count - 1).Paste
wddoc.Range(wddoc.Characters.Count - 1).InsertBreak (wdPageBreak)after the line:
instead of the ".range.paste" that you originially had.
The other issue with your "Selection" line is that you did not specify the application you wanted to use. This was using Excel's selection by default as it was being run from Excel.
This code assumes that you have a word document that doesn't have enough pages. Otherwise you could likely use the code you want, but it's unclear why you would have a blank word document with many pages. You'd still need to specify the app you want to move to the next page in, so put "wdapp." before the selection line.
http://word.tips.net/T000120_Jumping_to_the_Start_or_End_of_a_Document.html

Save embedded word document from Excel VBA

I have created the below code for exporting an embedded Word document in a Excel Sheet to the workbook's path:
Private Sub Export()
Dim sh As Shape
Dim objWord As Object 'Word.Document
Dim objOLE As OLEObject
Set sh = Sheet1.Shapes("Object 1")
sh.OLEFormat.Activate
Set objOLE = sh.OLEFormat.Object
Set objWord = objOLE.Object
objWord.SaveAs2 Filename:=ActiveWorkbook.Path & "\MyTemplate.docx", FileFormat:= _
wdFormatDocumentDefault
End Sub
The above code is working fine, but I was looking to add that the Word Applications starts as invisible and that it exits MS Word at the end of the code. I have tried using objWord.Visible = False and objWord.Quit but when I add these lines I get an "Object doesn't support this property or method" error.
Please advise.
I guess you want this
objWord.Application.Visible = False
and this
objWord.Application.Quit

Excel VBA: Copy XL named range values to DOC bookmarks, then export to PDF

I'm trying to copy the values from a named range in Excel to a bookmark in Word. I found this code on the web that does it in Excel VBA, but I'm getting an Error 13.
Set pappWord = CreateObject("Word.Application")
Set docWord = pappWord.Documents.Add(Path)
'Loop through names in the activeworkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
I know that the line that is causing the error is:
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
What am i doing wrong? Also, how & where would I code so that I can export the doc to PDF?
Thanks in advance.
Note: I've already selected the reference to the Microsoft Word (version number 14) Object model in Excel
so I use it to accomplish this task but taking an image from formatted Excel table.
Sub FromExcelToWord()
Dim rg As Range
For Each xlName In wb.Names
If docWord.Bookmarks.Exists(xlName.Name) Then
Set rg = Range(xlName.Value)
rg.Copy
docWord.ActiveWindow.Selection.Goto what:=-1, Name:=xlName.Name
docWord.ActiveWindow.Selection.PasteSpecial link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
0, DisplayAsIcon:=False
End If
Next xlName
End Sub
Just curious... Why are you adding a document rather than opening the relevant doc which has the bookmarks? Try this code (I usually test the code before posting but I haven't tested this particular code. Just quickly wrote it)
Also I am using Late Binding so no reference to the Word Object Library is required.
Sub Sample()
Dim wb As Workbook
Dim pappWord As Object, docWord As Object
Dim FlName As String
Dim xlName As Name
FlName = "C:\MyDoc.Doc" '<~~ Name of the file which has bookmarks
'~~> Establish an Word application object
On Error Resume Next
Set pappWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set pappWord = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
Set docWord = pappWord.Documents.Open(FlName)
Set wb = ActiveWorkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName).Value
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
End Sub
EDIT
Changed
Range(xlName.Value)
to
Range(xlName).Value
Now the above code is TRIED AND TESTED :)