I want to print a macro-enabled MS-Word Document that is embedded in a Excel Worksheet which it's name is SalaryPaycheck, from the excel macro module.
I using code below:
Sub PrintIt()
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim Oshp As Object
Dim strCurrentPrinter As String
ActiveSheet.OLEObjects("SalaryPaycheck").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set objDoc = objWord.ActiveDocument
objWord.Application.DisplayAlerts = wdAlertsNone
objDoc.Application.ActivePrinter = "Adobe PDF on Ne06:"
objDoc.PrintOut Background:=False
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
Application.ScreenUpdating = True
Exit Sub
End Sub 'Print it
The PrintOut opens a dialog box which asks about path and file name.
I want to made file name and path predefined so PrintOut runs quietly.
If you have an up-to-date Word version then you could export/save the file to a PDF document directly. Change your code to
Sub PrintIt()
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim Oshp As Object
Dim strCurrentPrinter As String
ActiveSheet.OLEObjects("SalaryPaycheck").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set objDoc = objWord.ActiveDocument
objWord.Application.DisplayAlerts = wdAlertsNone
' objDoc.Application.ActivePrinter = "Adobe PDF on Ne06:"
' objDoc.PrintOut Background:=False
Dim strOutFile As String
strOutFile = "<filename>.pdf"
objDoc.ExportAsFixedFormat OutputFileName:= _
strOutFile, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
Application.ScreenUpdating = True
Exit Sub
End Sub
Related
I have a code which copies data from a spreadsheet into specific bookmarks on a particular document. When it is run it works fine, but the bookmarks are deleted from the spreadsheet. Is there a way I can keep the bookmarks in the document
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet6")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\GR1 CPA Test1.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("CN1").Range.Text = ws.Range("C25").Value
.Bookmarks("CN2").Range.Text = ws.Range("C25").Value
.Bookmarks("CNo").Range.Text = ws.Range("C26").Value
.Bookmarks("CL1").Range.Text = ws.Range("C27").Value
.Bookmarks("Ex1").Range.Text = ws.Range("C28").Value
.Bookmarks("Ex2").Range.Text = ws.Range("C28").Value
.Bookmarks("Su1").Range.Text = ws.Range("C29").Value
.Bookmarks("Su2").Range.Text = ws.Range("C29").Value
.Bookmarks("Su3").Range.Text = ws.Range("C29").Value
.Save
.Close
End With
Set objWord = Nothing
End Sub
I've used this in the past:
'Replace the text in a bookmark or insert text into an empty (zero-length) bookmark
Sub SetBookmarkText(oDoc As Word.Document, sBookmark As String, sText As String)
Dim BMRange As Word.Range
If oDoc.Range.Bookmarks.Exists(sBookmark) Then
Set BMRange = oDoc.Range.Bookmarks(sBookmark).Range
BMRange.Text = sText
oDoc.Range.Bookmarks.Add sBookmark, BMRange
Else
MsgBox "Bookmark '" & sBookmark & "' not found in document '" & oDoc.Name & "'" & _
vbCrLf & "Content not updated"
End If
End Sub
Usage:
Dim ws As Worksheet, doc as object
Set ws = ThisWorkbook.Sheets("Sheet6")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set doc = objWord.Documents.Open("C:\GR1 CPA Test1.docx")
SetBookmarkText doc, "CN1", ws.Range("C25").Value
SetBookmarkText doc, "CN2", ws.Range("C25").Value
'etc etc
doc.Save
doc.Close
Set objWord = Nothing
End Sub
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
I have an embedded MS-Word document in an Excel Worksheet which name is SalaryPaycheck.
The MS-word document contains several linked fields to Worksheet cells.
I have update the linked cells, several times and perform updating above fields.
Then I need perform exporting the embedded MS-Word document each time the fields have updated, as PDF.
So I need all exported files are appending in a single pdf file.
I using below code:
Sub PrintIt()
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim i as Integer
ActiveSheet.OLEObjects("SalaryPaycheck").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set objDoc = objWord.ActiveDocument
objWord.Application.DisplayAlerts = wdAlertsNone
objWord.Application.ScreenUpdating = False
For i = 1 to 10
Range("Key").value = i
objDoc.Fields.Update
objDoc.ExportAsFixedFormat _
outputfileName:=ThisWorkbook.path & "\Results\" & "rep" & i & ".pdf" _
, exportformat:=wdExportFormatPDF _
, openafterexport:=False _
, optimizefor:=wdExportOptimizeForPrint _
, Range:=wdExportAllDocument _
, Item:=wdExportDocumentContent _
, includedocprops:=False _
, keepirm:=True _
, createbookmarks:=wdExportCreateNoBookmarks _
, docstructuretags:=True _
, bitmapmissingfonts:=True _
, useiso19005_1:=False
Next i
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub 'Print it
How can using objDoc.SaveAs2 or objDoc.ExportAsFixedFormat (shown above) same as objDoc.PrintOut' whith 'Append:=True argument?
Or How can using .PrintOut with 'Append:=True' argument in this case (PDF) which working quietly (using OutputFileName:=path & filename and PrintToFile:=True)
As said in the other question, just append the documents in word
Sub PrintIt()
Dim objWord As Word.Application
Dim objDocTotal As Word.Document
Dim objDoc As Word.Document
Dim i As Integer
Dim strOutfile As String
Dim rg As Word.Range
ActiveSheet.OLEObjects("SalaryPaycheck").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
Set objDoc = objWord.ActiveDocument
Set objDocTotal = Documents.Add
objWord.Application.DisplayAlerts = wdAlertsNone
objWord.Application.ScreenUpdating = True
For i = 1 To 10
Range("Key").Value = i
With objDoc
.Fields.Update
.Content.Copy
End With
Set rg = objDocTotal.Content
With rg
.Collapse Direction:=wdCollapseEnd
If i > 1 Then .InsertBreak wdPageBreak
.PasteAndFormat wdFormatOriginalFormatting
End With
Next i
strOutfile = "<Path>\Salary.pdf"
objDocTotal.ExportAsFixedFormat outputfileName:= _
strOutfile, exportformat:=wdExportFormatPDF, _
openafterexport:=False, optimizefor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent
objDocTotal.Close False
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub
Here is what I have so far :)
What I am trying to do is add the filepath and the file name into the footer in the word document, that is being created from excel...
Function ReportTypeC()
Dim wdApp As Word.Application
Dim wb As Workbook
Dim SrcePath As String
Dim FileName As String
FileName = ActiveDocument.FullName
SrcePath = "L:\TEST\Archive\unnamed.jpg"
Set wdApp = New Word.Application
With wdApp
.Visible = True
.Activate
.Documents.Add
Application.CutCopyMode = False
.ActiveDocument.Sections.Item(1).Headers(wdHeaderFooterPrimary) _
.Range.InlineShapes.AddPicture (SrcePath)
.ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary) _
.PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberLeft, FirstPage:=True
'With ActiveDocument.Sections(1)
'.Footers(wdHeaderFooterPrimary).Range.Text = "FileName"
'End With
End With
End Function
Here is your function for write document name in footer that you can extend for what your need.
Option Explicit
Function ReportTypeC()
Dim wdApp As Word.Application
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
wdApp.Documents.Add
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.TypeText Text:=ThisWorkbook.Path & thisworkbook.Name & ".docx"
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
appWD.ActiveDocument.SaveAs Filename:=ThisWorkbook.Path & thisworkbook.Name & ".docx"
wdApp.ActiveDocument.Close
wdApp.Quit
End Function
Your question is unclear.
If you need to have the Word document's name in the file, you have to save it first (and you have to give it a name).
Sub ReportTypeC()
Dim wdApp As New Word.Application
Dim wdDoc as Word.Document
Dim SrcePath As String
Dim FileName As String
SrcePath = "L:\TEST\Archive\unnamed.jpg"
With wdApp
.Visible = True
.Activate
Set wdDoc = .Documents.Add
End With
'Build your file path and file name here; I am using ThisWorkbook assuming we are exporting to the same directory as the workbook, and calling the exported document "mydocument.docx"
FileName = ThisWorkbook.Path & "\" & "mydocument.docx"
With wdDoc
.SaveAs FileName:=FileName
With .Sections(1)
.Headers(wdHeaderFooterPrimary).Range.InlineShapes.AddPicture SrcePath
.Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberLeft, FirstPage:=True
.Footers(wdHeaderFooterPrimary).Range.Text = FileName
End With
.Save
End With
End Sub
If you need to have the Excel workbook's filepath / name in the file, then you only need to refer to the ThisWorkbook object and its FullName property.
Sub ReportTypeC()
Dim wdApp As New Word.Application
Dim wdDoc as Word.Document
Dim SrcePath As String
SrcePath = "L:\TEST\Archive\unnamed.jpg"
With wdApp
.Visible = True
.Activate
Set wdDoc = .Documents.Add
End With
With wdDoc
With .Sections(1)
.Headers(wdHeaderFooterPrimary).Range.InlineShapes.AddPicture SrcePath
.Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberLeft, FirstPage:=True
.Footers(wdHeaderFooterPrimary).Range.Text = ThisWorkbook.FullName
End With
.Save
End With
End Sub
Personally, however, rather than build the document from scratch every time I call the macro, I would create a template, open the document in ReadOnly mode, and use find and replace to replace any dynamic data. Example
Sub ReportTypeC()
Dim wdApp As New Word.Application
Dim wdDoc as Word.Document
Dim SrcePath As String
Dim FileName As String
Dim wdRange as Word.Range
Const TemplatePath as String = "L:\TEST\Archive\Report C template.docx" ' This template contains the text "{{ FileName }}" and "{{ SourceWorkbook }}" in the footer, which is to be replaced.
SrcePath = "L:\TEST\Archive\unnamed.jpg"
With wdApp
.Visible = True
.Activate
Set wdDoc = .Documents.Open(FileName:=TemplatePath, ReadOnly:=True)
End With
' Exported file
FileName = "L:\TEST\Archive\" & "Report C " & Format(Now, "yyyy-mm-dd") & ".docx" ' e.g. "Report C 2017-09-27.docx"
With wdDoc
With .Sections(1).Footers(wdHeaderFooterPrimary)
' If we are sure that the template contains "{{ SourceWorkbook }}"), we can work with the range directly
FindRange(.Range, "{{ SourceWorkbook }}").Text = ThisWorkbook.FullName
' If we aren't sure whether the template contains "{{ FileName }}" we need to check there's a match, so it doesn't replace the whole footer range
Set wdRange = FindRange(.Range, "{{ FileName }}")
If wdRange.Text = "{{ FileName }}" Then wdRange.Text = FileName
End With
' Save the file
.SaveAs FileName:=FileName
End With
End Sub
Function FindRange(ByRef rLook As Word.Range, ByVal strFind As String) As Word.Range ' returns the first range that is matched by the strFind string
rLook.Find.Execute Findtext:=strFind, MatchCase:=True, Forward:=True, Wrap:=wdFindStop, MatchWholeWord:=True
Set FindRange = rLook
End Function
I have an Excel sheet with Microsoft Word OLE objects embedded.
My embedded Word documents have some fields that should been updated with specific cells.
I need to print the content of that embedded document, without visible document opening and "update document prompts".
My problem is in copying the content of the Word-embedded OLE object in an invisible Word document without update prompting.
I try this:
This code paint a box around the embedded word document in destination printable document.
Please help me copy content of embedded document or ..., and print an embedded document without updating prompt and visible window.
Sub PrintIt(P As String, w, h As Double)
Dim objWord As Object
Dim ObjDoc As Object
Application.ScreenUpdating = False
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
ActiveSheet.OLEObjects(P).Copy
Set ObjDoc = objWord.Documents.Add
ObjDoc.PageSetup.PageWidth = objWord.CentimetersToPoints(w)
ObjDoc.PageSetup.PageHeight = objWord.CentimetersToPoints(h)
ObjDoc.Content.Paste
ObjDoc.PrintOut Background:=False
ObjDoc.PrintOut
objWord.Quit SaveChanges:=False
Application.ScreenUpdating = True
End Sub 'Print it
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