none
Copying entire contents of one document into another document without using Clipboard RRS feed

  • Question

  • I have been using an application in VB.NET to automate word to copy multiple word documents into one target document based on users selection of source documents.

    I currently open each word document in turn with and use the WholeStory, Copy and then select the target document and use PasteAndFormat.

    I would like not to use the Clipboard, but the Range.FormattedText object or something similar to copy the contents from one document to another.

    Note that the source documents may also have tables, and other objects that require copying.

    The code that currently works, is long to handle multiple requirements on each source document

    Private Sub OpenDocumentButDontShow(ByVal oBaseDoc As Word.Document, ByVal oFile As Object, ByVal iPasteFormatType As Microsoft.Office.Interop.Word.WdRecoveryType, _
                                            Optional ByVal sHzSafetyInspect As String = "") ', Optional ByVal sHzToolboxMeet As String = "")
            ' Open the Document but dont show
            Dim isVisible As Object = False
            Dim wordReadOnly As Object = True
            Dim wordAddToRecentFiles As Object = False
            Static iBMCount As Integer = 0
    
            Try
    
                wordReadOnly = True
                WordApp.Documents.Open(oFile, , wordReadOnly, wordAddToRecentFiles, , , , , , , , isVisible)
                Dim oldAllowReadingMode As Boolean = WordApp.Options.AllowReadingMode
                WordApp.Options.AllowReadingMode = False
    
                ' Recently Open file becomes Document 1
                Dim wDoc As Word.Document = WordApp.Documents(1)
    
                SetWordPagination(wDoc)
    
                wDoc.Activate()
    
                ' Create a Home Bookmark at the begining of the document
                'wDoc.Bookmarks.Add("dgDocHome")
    
                ' ### Check if there is a bookmark at the very start of the document (Position 0)
                ' ### If there is get its End position
                Dim iInsertAt As Int32 = 0
                For Each bkM As Word.Bookmark In wDoc.Bookmarks
                    If bkM.Start = 0 Then
                        iInsertAt = bkM.End + 1
                        Exit For
                    End If
                Next
                ' ### Select a range to add the dgDocHome bookmark to
                Dim rng As Word.Range = wDoc.Range(iInsertAt.ToString)
                ' Create a Home Bookmark at the begining of the document
                rng.Bookmarks.Add("dgDocHome")
    
    
                ' Set a background colour object
                Dim bgCol As Int32 = 16777215
                For Each oShape As Word.Shape In wDoc.Shapes
                    If oShape.Type = Microsoft.Office.Core.MsoShapeType.msoTextBox Then
                        bgCol = oShape.Fill.ForeColor.RGB
                    End If
                Next
    
                For Each bkM As Word.Bookmark In wDoc.Bookmarks
                    Dim sBkm As String = bkM.Name.ToLower
                    Select Case True
                        Case sBkm Like "ProjectName*".ToLower
                            bkM.Select()
                            bkM.Range.Text = Entity.ProjectName
                            FormatText(bgCol)
                        Case sBkm Like "ProjectLocation*".ToLower
                            bkM.Select()
                            bkM.Range.Text = EntityAddress()
                            FormatText(bgCol)
                        Case sBkm Like "ProjectNumber*".ToLower
                            bkM.Select()
                            bkM.Range.Text = Entity.ProjectNo
                            FormatText(bgCol)
                        Case sBkm Like "CompanyName*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyName
                            FormatText(bgCol)
                        Case sBkm Like "CompanyAddress*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyAddress
                            FormatText(bgCol)
                        Case sBkm Like "CompanyPhone*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyPhone
                            FormatText(bgCol)
                        Case sBkm Like "CompanyFax*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyFax
                            FormatText(bgCol)
                        Case sBkm Like "CompanyEmail*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyEmail
                            FormatText(bgCol)
                        Case sBkm Like "CompanyMobile*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyMobile
                            FormatText(bgCol)
                        Case sBkm Like "CompanyABN*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyABN
                            FormatText(bgCol)
                        Case sBkm Like "CompanyResponsibleOfficer*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyResponsibleOfficer
                            FormatText(bgCol)
                        Case sBkm Like "CompanyEither*".ToLower
                            bkM.Select()
                            If Subcontractors.Count > 0 Then
                                bkM.Range.Text = "does"
                            Else
                                bkM.Range.Text = "does not"
                            End If
                            FormatText(bgCol)
                        Case sBkm Like "AssociationCert_1*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyAssociateCert1
                            FormatText(bgCol)
                        Case sBkm Like "AssociationCert_2*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyAssociateCert2
                            FormatText(bgCol)
                        Case sBkm Like "ContractorLicence*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyContractorLicense
                            FormatText(bgCol)
                        Case sBkm Like "InsuranceCertContractWorks*".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyInsuranceCertContractWorks
                            FormatText(bgCol)
                        Case sBkm Like "InsuranceCertLiability".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyInsuranceCertLiability
                            FormatText(bgCol)
                        Case sBkm Like "WorkCover".ToLower
                            bkM.Select()
                            bkM.Range.Text = CompanyWorkCover
                            FormatText(bgCol)
                        Case sBkm Like "TradeActivity*".ToLower
                            bkM.Select()
                            bkM.Range.Text = TradeActivity
                            FormatText(bgCol)
                        Case sBkm Like "StartDate*".ToLower
                            bkM.Select()
                            bkM.Range.Text = String.Format("{0:d}", Entity.PlannedStartDate)
                            FormatText(bgCol)
                        Case sBkm Like "EndDate*".ToLower
                            bkM.Select()
                            bkM.Range.Text = String.Format("{0:d}", Entity.PlannedEndDate)
                            FormatText(bgCol)
                        Case sBkm Like "WorkDescription*".ToLower
                            bkM.Select()
                            bkM.Range.Text = Entity.ProjectDescription
                            FormatText(bgCol)
                        Case sBkm Like "EmployeeNumber*".ToLower
                            bkM.Select()
                            bkM.Range.Text = SelectedWorkers.DistinctValues("WorkerID").Count.ToString
                            FormatText(bgCol)
                        Case sBkm Like "AdditionalSupervisor*".ToLower
                            bkM.Select()
                            Dim iSiteSupCount As Int32 = 0
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.SiteSafetyOfficer Then
                                    iSiteSupCount += 1
                                    ' ### We only want the second site supervisor
                                    If iSiteSupCount = 2 Then
                                        bkM.Range.Text = String.Format("or {0}", FetchWorkerName(w.WorkerID, False))
                                        Exit For
                                    End If
                                End If
                            Next
                            FormatText(bgCol)
    
                        Case sBkm = "EmergencyContactTitle".ToLower
                            bkM.Select()
                            CreateHeading2(WordApp, wDoc, bkM, "Doctors", "Project Emergency Medical Service Contact")
    
                        Case sBkm = "EmergencyContactTable".ToLower
                            bkM.Select()
                            CreateTable(WordApp, wDoc, SelectedDoctors, 3, bkM)
    
                        Case sBkm = "SiteSafetyOfficerTitle".ToLower
                            bkM.Select()
                            CreateHeading2(WordApp, wDoc, bkM, "SiteSafety", "Site Safety Officer")
    
                        Case sBkm = "SiteSafetyOfficerTable".ToLower
                            bkM.Select()
                            CreateTable(WordApp, wDoc, SelectedWorkers, 4, bkM, "SiteSafetyOfficer")
    
                        Case sBkm = "TrainedFirstAidPersonnelTitle".ToLower
                            bkM.Select()
                            CreateHeading2(WordApp, wDoc, bkM, "FirstAid", "Trained First Aid Personnel")
    
                        Case sBkm = "TrainedFirstAidPersonnelTable".ToLower
                            bkM.Select()
                            CreateTable(WordApp, wDoc, SelectedWorkers, 4, bkM, "FirstAidRepresentative")
    
                        Case sBkm Like "OHSCoordinator*".ToLower
                            bkM.Select()
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.OHSRepresentative Then
                                    bkM.Range.Text = FetchWorkerName(w.WorkerID, True)
                                    Exit For
                                End If
                            Next
                            FormatText(bgCol)
    
                        Case sBkm Like "ProjectManager*".ToLower
                            bkM.Select()
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.ProjectManager Then
                                    bkM.Range.Text = FetchWorkerName(w.WorkerID, True)
                                    Exit For
                                End If
                            Next
                            FormatText(bgCol)
    
                        Case sBkm Like "ReturntoWorkCoordinator*".ToLower
                            bkM.Select()
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.ReturnToWorkCoord Then
                                    bkM.Range.Text = FetchWorkerName(w.WorkerID, True)
                                    Exit For
                                End If
                            Next
                            FormatText(bgCol)
    
                        Case sBkm Like "SiteSafetyOfficer*".ToLower
                            bkM.Select()
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.SiteSafetyOfficer Then
                                    bkM.Range.Text = FetchWorkerName(w.WorkerID, True)
                                    Exit For
                                End If
                            Next
                            FormatText(bgCol)
    
                        Case sBkm Like "SiteSupervisor*".ToLower
                            bkM.Select()
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.SiteSuperviser Then
                                    bkM.Range.Text = FetchWorkerName(w.WorkerID, True)
                                    Exit For
                                End If
                            Next
                            FormatText(bgCol)
    
                        Case sBkm Like "WorkersExternal*".ToLower
                            bkM.Select()
                            Dim sExtWorkers As String = ""
                            For Each w As ProjectWorker In SelectedWorkers
    
                                If w.SubcontractorID IsNot Nothing AndAlso (w.OHSRepresentative Is Nothing OrElse Not w.OHSRepresentative) _
                                    AndAlso (w.FirstAidRepresentative Is Nothing OrElse Not w.FirstAidRepresentative) _
                                    AndAlso (w.ProjectManager Is Nothing OrElse Not w.ProjectManager) _
                                    AndAlso (w.SiteSuperviser Is Nothing OrElse Not w.SiteSuperviser) _
                                    AndAlso (w.SiteSafetyOfficer Is Nothing OrElse Not w.SiteSafetyOfficer) _
                                    AndAlso (w.ReturnToWorkCoord Is Nothing OrElse Not w.ReturnToWorkCoord) _
                                    AndAlso (w.IsDeleted Is Nothing OrElse Not w.IsDeleted) Then
    
                                    If String.IsNullOrEmpty(sExtWorkers) Then
                                        sExtWorkers = w.WorkerName
                                    Else
                                        sExtWorkers = sExtWorkers & vbCrLf & w.WorkerName
                                    End If
    
                                End If
    
                            Next
                            bkM.Range.Text = sExtWorkers
                            FormatText(bgCol)
    
                        Case sBkm Like "WorkersInternal*".ToLower
                            bkM.Select()
                            Dim sIntWorkers As String = ""
    
                            For Each w As ProjectWorker In SelectedWorkers
    
                                If w.SubcontractorID Is Nothing AndAlso (w.OHSRepresentative Is Nothing OrElse Not w.OHSRepresentative) _
                                    AndAlso (w.FirstAidRepresentative Is Nothing OrElse Not w.FirstAidRepresentative) _
                                    AndAlso (w.ProjectManager Is Nothing OrElse Not w.ProjectManager) _
                                    AndAlso (w.SiteSuperviser Is Nothing OrElse Not w.SiteSuperviser) _
                                    AndAlso (w.SiteSafetyOfficer Is Nothing OrElse Not w.SiteSafetyOfficer) _
                                    AndAlso (w.ReturnToWorkCoord Is Nothing OrElse Not w.ReturnToWorkCoord) _
                                    AndAlso (w.IsDeleted Is Nothing OrElse Not w.IsDeleted) Then
    
                                    If String.IsNullOrEmpty(sIntWorkers) Then
                                        sIntWorkers = w.WorkerName
                                    Else
                                        sIntWorkers = sIntWorkers & vbCrLf & w.WorkerName
                                    End If
    
                                End If
    
                            Next
                            bkM.Range.Text = sIntWorkers
                            FormatText(bgCol)
    
                        Case sBkm = "revisionno"
                            bkM.Select()
    
                            Dim iRevCount As Int32 = 0
                            Dim iRevNo As Int32 = 0
                            For Each rev As VProjectRevisionHistory In RevisionHistory
                                iRevCount += 1
    
                                wDoc.Application.Selection.TypeText(rev.RevisionNo.ToString)
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                wDoc.Application.Selection.TypeText(rev.RevisionReason)
    
                                If iRevCount = RevisionHistory.Count Then
                                    If Not bCreateDocNoEdit Then
                                        iRevNo = CType(rev.RevisionNo, Int32) + 1
                                    Else
                                        iRevNo = CType(rev.RevisionNo, Int32)
                                    End If
    
                                Else
                                    wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                End If
                            Next
    
                            If Not bCreateDocNoEdit Then
    
                                Dim rows As List(Of VBaseActiveWizardQuestion)
    
                                ' Find the the Revision Reason Question Answer in the Wizard Questions
                                rows = WizardQuestions.ToList.FindAll(Function(p) p.ResponseTypeID = 2)
    
                                For Each row As VBaseActiveWizardQuestion In rows
                                    If row.Question.ToLower.Contains("revis") Then
                                        If iRevNo > 0 Then
                                            wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                        Else
                                            iRevNo = 1
                                        End If
                                        wDoc.Application.Selection.TypeText(iRevNo.ToString)
                                        wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                        wDoc.Application.Selection.TypeText(row.Answer.ToString)
                                    End If
                                Next
    
                            End If
    
                            wDoc.Bookmarks("SigRevisionNo").Select()
                            ' ### Fill in the details of who created the previous versions and when
                            iRevCount = 0
                            For Each rev As VProjectRevisionHistory In RevisionHistory
                                iRevCount += 1
    
                                wDoc.Application.Selection.TypeText(rev.RevisionNo.ToString)
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                wDoc.Application.Selection.TypeText(FormatDateTime(CType(rev.ModifiedOn, DateTime), DateFormat.ShortDate))
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                wDoc.Application.Selection.TypeText(rev.ModifiedBy.ToString)
    
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell) ' Checked By
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell) ' Approved By
    
                                If iRevCount <> RevisionHistory.Count Then
                                    wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                End If
                            Next
    
                            If Not bCreateDocNoEdit Then
                                ' ### Fill in who created this version
                                If iRevNo > 1 Then
                                    wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                End If
                                wDoc.Application.Selection.TypeText(iRevNo.ToString)
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                wDoc.Application.Selection.TypeText(FormatDateTime(_DALUtilities.GetServerNow, DateFormat.ShortDate))
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                wDoc.Application.Selection.TypeText(Datagaard.FrameWork.GetUserID)
                            End If
    
                        Case sBkm = "projectsubcontractors"
                            bkM.Select()
    
                            Dim iSubCount As Int32 = 0
                            Dim sSubAddress As String
                            For Each subC As SubcontractorMaster In Subcontractors
                                iSubCount += 1
    
                                wDoc.Application.Selection.TypeText(iSubCount.ToString)
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                wDoc.Application.Selection.TypeText(subC.ContractorName.ToString)
                                wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
    
                                ' ### Format the address
                                sSubAddress = subC.AddressLine1
                                If Not String.IsNullOrEmpty(subC.AddressLine2) Then
                                    sSubAddress = String.Format("{0}{1}{2}", sSubAddress, vbCrLf, subC.AddressLine2)
                                End If
                                If Not String.IsNullOrEmpty(subC.AddressLine3) Then
                                    sSubAddress = String.Format("{0}{1}{2}", sSubAddress, vbCrLf, subC.AddressLine3)
                                End If
                                If Not String.IsNullOrEmpty(subC.Locality) Then
                                    sSubAddress = String.Format("{0}{1}{2}, {3}, {4}", sSubAddress, vbCrLf, subC.Locality, subC.ContractorState, subC.PostCode)
                                End If
                                If Not String.IsNullOrEmpty(subC.PhoneNo) Then
                                    sSubAddress = String.Format("{0}{1}Ph: {2}", sSubAddress, vbCrLf, subC.PhoneNo)
                                End If
                                If Not String.IsNullOrEmpty(subC.FaxNo) Then
                                    sSubAddress = String.Format("{0}{1}Fax: {2}", sSubAddress, vbCrLf, subC.FaxNo)
                                End If
    
                                wDoc.Application.Selection.TypeText(sSubAddress)
    
                                If iSubCount <> Subcontractors.Count Then
                                    wDoc.Application.Selection.MoveRight(Unit:=Word.WdUnits.wdCell)
                                End If
    
                            Next
    
                        Case sBkm = "projectkeypersonnel"
                            bkM.Select()
                            Dim sSectionName As String = Nothing
                            Dim bSkipCreateTable As Boolean = False
                            Dim bSiteSafetyOfficer As Boolean = False
    
                            SelectedWorkers.Sort("QuestionID")
    
                            Dim sRoleName As String = ""
                            For i As Int32 = 1 To 5
                                ' ### Display the workers in a certain order
                                Select Case i
                                    Case 1
                                        sRoleName = ProjectWorkerSchema.ColumnNames.ProjectManager
                                    Case 2
                                        sRoleName = ProjectWorkerSchema.ColumnNames.SiteSuperviser
                                    Case 3
                                        sRoleName = ProjectWorkerSchema.ColumnNames.SiteSafetyOfficer
                                    Case 4
                                        sRoleName = ProjectWorkerSchema.ColumnNames.OHSRepresentative
                                    Case 5
                                        sRoleName = ProjectWorkerSchema.ColumnNames.ReturnToWorkCoord
                                    Case Else
                                End Select
    
                                Dim iCount As Int32 = 0
                                Dim tbl As Word.Table = Nothing
                                For Each w As ProjectWorker In SelectedWorkers
    
                                    sSectionName = Nothing
                                    bSkipCreateTable = False
    
                                    Select Case True
                                        Case w.OHSRepresentative And Not w.IsDeleted And w.OHSRepresentativeColumn.Name = sRoleName
                                            sSectionName = "Safety System Coordinator" ' "OHS Coordinator"
                                            iCount += 1
                                        Case w.ProjectManager And Not w.IsDeleted And w.ProjectManagerColumn.Name = sRoleName
                                            sSectionName = "Project Manager"
                                            iCount += 1
                                        Case w.SiteSuperviser And Not w.IsDeleted And w.SiteSuperviserColumn.Name = sRoleName
                                            sSectionName = "Site Supervisor"
                                            iCount += 1
                                        Case w.SiteSafetyOfficer And Not w.IsDeleted And w.SiteSafetyOfficerColumn.Name = sRoleName
    
                                            If Not bSiteSafetyOfficer Then
                                                sSectionName = "Site Safety Officer"
                                                bSiteSafetyOfficer = True
                                            End If
                                            iCount += 1
                                        Case w.ReturnToWorkCoord And Not w.IsDeleted And w.ReturnToWorkCoordColumn.Name = sRoleName
                                            sSectionName = "Return to Work Coordinator"
                                            iCount += 1
                                        Case Else
                                    End Select
    
                                    If sSectionName IsNot Nothing Then
    
                                        If iCount = 1 Then
                                            CreateHeading2(WordApp, wDoc, bkM, "Section 2.5", sSectionName)
                                            CreateTable(WordApp, wDoc, w, 4, tbl)
                                        Else
                                            Dim vWZBaseWorker As VWZBaseWorker = FetchVWZBaseWorker(w.WorkerID)
                                            tbl.Rows.Add()
                                            TableCellSetup(tbl.Cell(iCount + 1, 1), False, vWZBaseWorker.WorkerName)
                                            TableCellSetup(tbl.Cell(iCount + 1, 2), False, vWZBaseWorker.ContractorName)
                                            TableCellSetup(tbl.Cell(iCount + 1, 3), True, vWZBaseWorker.AccreditationName)
                                            TableCellSetup(tbl.Cell(iCount + 1, 4), True, vWZBaseWorker.MobileNo)
                                            WordApp.Selection.EndKey(Word.WdUnits.wdStory, Word.WdMovementType.wdMove)
                                        End If
    
                                    End If
    
                                Next
    
                            Next
    
                        Case sBkm Like "safetyinspections*"
                            bkM.Select()
    
                            Dim iSiteSupCount As Int32 = 0
                            Dim sAdditionalSupervisor As String = ""
    
                            For Each w As ProjectWorker In SelectedWorkers
                                If w.SiteSafetyOfficer Then
                                    iSiteSupCount += 1
                                    ' ### We only want the second site supervisor
                                    If iSiteSupCount = 2 Then
                                        sAdditionalSupervisor = FetchWorkerName(w.WorkerID, False)
                                        Exit For
                                    End If
                                End If
                            Next
    
                            CreateTable(WordApp, wDoc, 4, sAdditionalSupervisor, sHzSafetyInspect)
    
                        Case sBkm = "summary"
                            ' ### Used on the cover page if the document is a summary
                            If PDFType.ToLower Like "summar*" Then
                                bkM.Select()
                                WordApp.Selection.TypeParagraph()
                                WordApp.Selection.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphCenter
                                WordApp.Selection.TypeText("SUMMARY")
                                FormatText(bgCol)
                            End If
                        Case Else
                    End Select
                Next
    
                'wDoc.Bookmarks.Add("dgDocHome")
                wDoc.Bookmarks("dgDocHome").Select()
    
                Dim bAddSectionBreak As Boolean
                If wDoc.PageSetup.Orientation = Word.WdOrientation.wdOrientLandscape Then
                    ' Here we can set a flag to notify of pending page orientation change required
                    bAddSectionBreak = True
                End If
    
                ' Select the Document to Copy
                wDoc.Application.Selection.WholeStory()
                wDoc.Application.Selection.Copy()
                wDoc.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
                wDoc = Nothing
    
                ' Select the Active Document 
                oBaseDoc.Select()
    
                WordApp.Selection.EndKey(Word.WdUnits.wdStory)
                WordApp.Selection.EndKey(Word.WdUnits.wdStory, Word.WdMovementType.wdMove)
    
                If bAddSectionBreak Then
                    ' Here is where we could change the page orientation to Landscape
                    WordApp.Selection.InsertBreak(Type:=Word.WdBreakType.wdSectionBreakNextPage)
                End If
    
                ' Create a Home Bookmark at the begining of the document
                iBMCount += 1
                oBaseDoc.Bookmarks.Add(String.Format("dgDocHome{0}", CStr(iBMCount)))
    
                WordApp.Selection.PasteAndFormat(iPasteFormatType)
    
                oBaseDoc.Bookmarks(String.Format("dgDocHome{0}", CStr(iBMCount))).Select()
    
                ' Seek The Header and Link to Previous
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekCurrentPageHeader
                WordApp.ActiveWindow.ActivePane.Application.Selection.HeaderFooter.LinkToPrevious = True
    
                ' Seek the Main Document
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekMainDocument
    
                WordApp.Selection.EndKey(Word.WdUnits.wdStory)
                WordApp.Selection.EndKey(Word.WdUnits.wdStory, Word.WdMovementType.wdMove)
    
                ' Seek The Header and Link to Previous
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekCurrentPageHeader
                WordApp.ActiveWindow.ActivePane.Application.Selection.HeaderFooter.LinkToPrevious = True
    
                ' Seek the Footer and Link to Previous
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekCurrentPageFooter
                WordApp.ActiveWindow.ActivePane.Application.Selection.HeaderFooter.LinkToPrevious = True
    
                oBaseDoc.Bookmarks(String.Format("dgDocHome{0}", CStr(iBMCount))).Delete()
    
                ' Seek the Main Document
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekMainDocument
    
                WordApp.Selection.InsertBreak(Type:=Word.WdBreakType.wdSectionBreakNextPage)
    
                If WordApp.Selection.PageSetup.Orientation <> Word.WdOrientation.wdOrientPortrait Then
                    SetPageOrientation(WordApp)
                End If
            Catch ex As Exception
                MsgBox(String.Format("Unable to open document {0} for copy {1}{2}", oFile, vbCrLf, ex.ToString), MsgBoxStyle.Critical, "Error Opening Document")
            End Try
    
        End Sub
    Hoping you can give some insight in how best to do this.

    Tuesday, August 22, 2017 4:56 AM

Answers

  • At the conclusion of the copying I set the oBaseDoc orientation back to portrait, as other code may require to modify the oBaseDoc before another wDoc is copied.


                    Dim HdFt As Word.HeaderFooter
                    With WordApp.ActiveDocument.Sections.Last
                        For Each HdFt In .Headers
                            HdFt.LinkToPrevious = False
                        Next
                        For Each HdFt In .Footers
                            HdFt.LinkToPrevious = False
                        Next
                    End With
                End If
                wDoc.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
                wDoc = Nothing


    I trust that, to set the orientation back to portrait, you're inserting another Section break...

    As for your code, you seem to have ignored my advice! You still have:
    With WordApp.ActiveDocument.Sections.Last
    instead of:
    With WordApp.oBaseDoc.Sections.Last
    or even:
    With .Sections.Last
    (it's hard for me to tell whether your code is already working with oBaseDoc)

    Using ActiveDocument leaves your code at the mercy of whichever document your code last activated.

    That said, if the headers are unlinking as they should, I cannot see how it is possible for the footers to not also unlink; they are, after all, using the same process as for the headers - and it works flawlessly in VBA.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by KG Inoz Wednesday, August 30, 2017 2:40 AM
    Tuesday, August 29, 2017 8:33 AM

All replies

  • Leaving aside the question of widespread inefficiencies in your code (Hint there's nothing you're doing that requires anything to be selected or for the View to be swapped back & forth), in VBA (I don't do VB.Net) - except for the bookmark addition code - you could replace all of:

                ' Select the Document to Copy
                wDoc.Application.Selection.WholeStory()
                wDoc.Application.Selection.Copy()
                wDoc.Close (Word.WdSaveOptions.wdDoNotSaveChanges)
                wDoc = Nothing
    
                ' Select the Active Document
                oBaseDoc.Select()
    
                WordApp.Selection.EndKey (Word.WdUnits.wdStory)
                WordApp.Selection.EndKey(Word.WdUnits.wdStory, Word.WdMovementType.wdMove)
    
                If bAddSectionBreak Then
                    ' Here is where we could change the page orientation to Landscape
                    WordApp.Selection.InsertBreak(Type:=Word.WdBreakType.wdSectionBreakNextPage)
                End If
    
                ' Create a Home Bookmark at the begining of the document
                iBMCount += 1
                oBaseDoc.Bookmarks.Add(String.Format("dgDocHome{0}", CStr(iBMCount)))
    
                WordApp.Selection.PasteAndFormat (iPasteFormatType)

    with:

                ' Update the Active Document
                With oBaseDoc.Range
                  .InsertAfter vbCr
                  If bAddSectionBreak Then .Characters.Last.InsertBreak Type:=wdSectionBreakNextPage
                  .Characters.Last.FormattedText = wDoc.Range.FormattedText
                End With
                wDoc.Close wdDoNotSaveChanges
                Set wDoc = Nothing

    I'll leave you to do the VB.Net adaptation.

    Note: The FormattedText method will replicate all header/footer content from the source range except for header/footer content in the source document's last Section.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Proposed as answer by macropodMVP Monday, August 28, 2017 4:34 AM
    Tuesday, August 22, 2017 6:42 AM
  • Hi Paul,

    Thanks for the tip which I tried and works. Well sort of.

    The issue I have now is if the source documents page orientation changes to Landscape. The target document starts out in portrait, and I want the source documents original page layout and format to be retained.

    I have attempted to change the page orientation to landscape but it is setting it for the entire target document rather than just the added source document being copied into the target document.

    With oBaseDoc.Range
    	.InsertAfter(vbCr)
        If bAddSectionBreak Then
    		.Characters.Last.InsertBreak(Type:=Word.WdBreakType.wdSectionBreakNextPage)
            .Characters.Last.FormattedText = wDoc.Range.FormattedText
            .PageSetup.Orientation = Word.WdOrientation.wdOrientPortrait
        Else
            .Characters.Last.FormattedText = wDoc.Range.FormattedText
        End If
    End With
    Thanks

    Friday, August 25, 2017 3:05 AM
  • That's as simple as:

    .Sections.Last.PageSetup.Orientation = Word.WdOrientation.wdOrientPortrait


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Proposed as answer by macropodMVP Monday, August 28, 2017 4:33 AM
    Friday, August 25, 2017 12:19 PM
  • Hi Paul,

    Great that helps.

    Now how do I get the header/footer to extend to the edge of the landscape page.

    I am using a template .dotx document portrait orientation whose header is set 100% preferred width.

    When I add a new section, then change the page orientation to landscape (as above questions) the header and footer don't extend to the preferred width of 100%.

    Is there a way in code to do this?

    Regards

    Monday, August 28, 2017 12:56 AM
  • Now how do I get the header/footer to extend to the edge of the landscape page.

    ...

    When I add a new section, then change the page orientation to landscape (as above questions) the header and footer don't extend to the preferred width of 100%.

    The only way of doing that would be to disconnect the new Section's header/footer from the previous Section. Unless you're using tables tabs and/or spaces to manage the layout, that's all you should need to get Word to reformat the last Section's header/footer to fit the new layout. If you're using tabs, you might find it better to use a borderless multi-column table as the header/footer content container and set the table's preferred width to 100% - likewise if you're using a table.

    VBA code:

    Dim HdFt As HeaderFooter
    With ActiveDocument.Sections.Last
      .PageSetup.Orientation = wdOrientPortrait
      For Each HdFt In .Headers
        HdFt.LinkToPrevious = False
      Next
      For Each HdFt In .Footers
        HdFt.LinkToPrevious = False
      Next
    End With


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Monday, August 28, 2017 4:34 AM
  • Hi Paul,

    Thanks again for your insight and help. The code above seems to work fine for the headers but not the footers of the template .dotx document.

    Her is the link to the template in question. template document


    Tuesday, August 29, 2017 12:23 AM
  • The code I posted affects only the active document. Unless you've opened the template for editing (which your posted code doesn't appear to do, unless wDoc [which refers to oFile] or oBaseDoc is a template), the template remains unaffected. Naturally, you should replace ActiveDocument in the code I posted with the appropriate reference to wDoc or oBaseDoc to ensure the correct one gets edited. For example(VBA):

    With oBaseDoc.Range
        .InsertAfter (vbCr)
        If bAddSectionBreak Then
            .Characters.Last.InsertBreak wdSectionBreakNextPage
            With .Sections.Last
                .PageSetup.Orientation = wdOrientPortrait
                For Each HdFt In .Headers
                    HdFt.LinkToPrevious = False
                Next
                For Each HdFt In .Footers
                    HdFt.LinkToPrevious = False
                Next
            End With
        End If
        .Characters.Last.FormattedText = wDoc.Range.FormattedText
    End With


    Cheers
    Paul Edstein
    [MS MVP - Word]



    • Edited by macropodMVP Tuesday, August 29, 2017 1:26 AM Code sample
    Tuesday, August 29, 2017 1:09 AM
  • Hi Paul,

    I really appreciate your help on this matter, as I am getting closer. Always open to suggestions on improving code and efficiency. 

    I have posted amended code below, but still the footed doesn't alter even if I use oBaseDoc.

    Can I explain as to the purpose of this code and what I am attempting to achieve.

    Basically, oBaseDoc is the target word document based on the word template TAS_ProjectTemplate.dotx. wDoc is a source word document that gets opened without showing to have its bookmarks populated with data. Then wDoc is copied into oBaseDoc using formattedText.

    If wDoc orientation is landscape, I add a section break next page before copying wDoc, then set the page orientation to landscape. Attempting to set headers and footers to not linked.

    At the conclusion of the copying I set the oBaseDoc orientation back to portrait, as other code may require to modify the oBaseDoc before another wDoc is copied.

    I hope that paints a far better picture to what I first posted.

    Regards

    ' wDoc is the working source document that is having it's bookmarks populated.
    ' oBaseDoc is the target document where wDoc gets copied to.
                wDoc.Bookmarks("dgDocHome").Select()

                Dim bAddSectionBreak As Boolean
                If wDoc.PageSetup.Orientation = Word.WdOrientation.wdOrientLandscape Then
                    ' Here we can set a flag to notify of pending page orientation change required
                    bAddSectionBreak = True
                End If

                ' Select the Document to Copy
                wDoc.Application.Selection.WholeStory()

                Dim oSourceRange As Word.Range

                oSourceRange = wDoc.Application.Selection.FormattedText

                ' Select the Active Document 
                oBaseDoc.Select()

                ' Create a Home Bookmark to return to
                iBMCount += 1
                oBaseDoc.Bookmarks.Add(String.Format("dgDocHome{0}", CStr(iBMCount)))

                WordApp.Selection.EndKey(Word.WdUnits.wdStory)
                WordApp.Selection.EndKey(Word.WdUnits.wdStory, Word.WdMovementType.wdMove)
                If bAddSectionBreak Then
                    WordApp.Selection.InsertBreak(Type:=Word.WdBreakType.wdSectionBreakNextPage)
                    Dim tr As Word.Range
                    tr = WordApp.Selection.Range

                    tr.FormattedText = oSourceRange.FormattedText
                    SetPageOrientation(WordApp, Word.WdOrientation.wdOrientLandscape)
                    Dim HdFt As Word.HeaderFooter
                    With WordApp.ActiveDocument.Sections.Last
                        For Each HdFt In .Headers
                            HdFt.LinkToPrevious = False
                        Next
                        For Each HdFt In .Footers
                            HdFt.LinkToPrevious = False
                        Next
                    End With
                Else
                    Dim tr As Word.Range
                    tr = WordApp.Selection.Range

                    tr.FormattedText = oSourceRange.FormattedText
                End If

                oBaseDoc.Bookmarks(String.Format("dgDocHome{0}", CStr(iBMCount))).Select()

                ' Seek the Main Document
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekMainDocument

                WordApp.Selection.EndKey(Word.WdUnits.wdStory)
                WordApp.Selection.EndKey(Word.WdUnits.wdStory, Word.WdMovementType.wdMove)

                oBaseDoc.Bookmarks(String.Format("dgDocHome{0}", CStr(iBMCount))).Delete()

                ' Seek the Main Document
                WordApp.ActiveWindow.ActivePane.View.SeekView = Word.WdSeekView.wdSeekMainDocument

                WordApp.Selection.InsertBreak(Type:=Word.WdBreakType.wdSectionBreakNextPage)

                If WordApp.Selection.PageSetup.Orientation <> Word.WdOrientation.wdOrientPortrait Then
                    SetPageOrientation(WordApp, Word.WdOrientation.wdOrientPortrait)
                    Dim HdFt As Word.HeaderFooter
                    With WordApp.ActiveDocument.Sections.Last
                        For Each HdFt In .Headers
                            HdFt.LinkToPrevious = False
                        Next
                        For Each HdFt In .Footers
                            HdFt.LinkToPrevious = False
                        Next
                    End With
                End If
                wDoc.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
                wDoc = Nothing


    • Edited by KG Inoz Tuesday, August 29, 2017 5:27 AM
    Tuesday, August 29, 2017 5:15 AM
  • At the conclusion of the copying I set the oBaseDoc orientation back to portrait, as other code may require to modify the oBaseDoc before another wDoc is copied.


                    Dim HdFt As Word.HeaderFooter
                    With WordApp.ActiveDocument.Sections.Last
                        For Each HdFt In .Headers
                            HdFt.LinkToPrevious = False
                        Next
                        For Each HdFt In .Footers
                            HdFt.LinkToPrevious = False
                        Next
                    End With
                End If
                wDoc.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
                wDoc = Nothing


    I trust that, to set the orientation back to portrait, you're inserting another Section break...

    As for your code, you seem to have ignored my advice! You still have:
    With WordApp.ActiveDocument.Sections.Last
    instead of:
    With WordApp.oBaseDoc.Sections.Last
    or even:
    With .Sections.Last
    (it's hard for me to tell whether your code is already working with oBaseDoc)

    Using ActiveDocument leaves your code at the mercy of whichever document your code last activated.

    That said, if the headers are unlinking as they should, I cannot see how it is possible for the footers to not also unlink; they are, after all, using the same process as for the headers - and it works flawlessly in VBA.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by KG Inoz Wednesday, August 30, 2017 2:40 AM
    Tuesday, August 29, 2017 8:33 AM
  • Hi Paul,

    I haven't ignored your code suggestion, just that WordApp.oBaseDoc doesn't work, as oBaseDoc is not a member of microsoft.office.interop.word._application. No late binding in VB.NET with option Explicit.

    By selecting oBaseDoc "oBaseDoc.Select()" the WordApp object becomes oBaseDoc.

    However I have now since discovered that the footer in the TAS_ProjectTemplate.dotx was not set to "Preferred width ticked" and 100% as well as the options "Automatic resize to fit contents" wasn't ticked.

    Once this was changed then all worked okay.

    Thanks for great help.

    Wednesday, August 30, 2017 2:40 AM