I am trying to code around a copy and paste issue with Word. In that ifyou
copy and paste the contents of a document that has multiple sections into an
existing document, it brings with it header and footer information. I know
if I manually select the content of each section in turn and past that,
headers and footers remain unaffected. I need to recreate this in code.
Currently I use:
Sub InsertTextFromBoilerPlate()
Dim dlgOpen As FileDialog
Dim strFileLoc As String
Dim vrtSelectedItemFields As Variant
On Error Resume Next
Dim ChkResults As Variant
If IsMissing(ActiveDocument.CustomDocumentProperties("ValidTemplate"))
Then
MsgBox "This toolbar is restricted to Valid Corporate templates
only..."
Exit Sub
End If
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
With dlgOpen
.Filters.Add "Word Document Format", "*.doc", 1
If .Show = -1 Then
.AllowMultiSelect = False
For Each vrtSelectedItemFields In .SelectedItems
strFileLoc = vrtSelectedItemFields
Next vrtSelectedItemFields
Else
End If
End With
Set dlgOpen = Nothing
If strFileLoc = "" Then
Else
Documents.Open FileName:=strFileLoc, ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
Selection.WholeStory
Selection.Expand (wdMainTextStory)
Selection.Copy
ActiveDocument.Close
Selection.PasteAndFormat (wdPasteDefault)
'Selection.InsertFile FileName:=strFileLoc, Range:="",_
'ConfirmConversions:=False, Link:=False, Attachment:=False
End If
End Sub
I have experimented with selecting sections, but it always brings the Header
and Footer. Does anyone know how to select the text within a section,
meaning section(1) line 1 to last line of section? Or another way of solving
this problem?
Your assistance is appreciated, Mark
FIXED THIS ISSUE, Here is my code for any of you with a similar
problem....
Sub InsertTextFromBoilerPlate()
Dim dlgOpen As FileDialog
Dim strFileLoc As String
Dim vrtSelectedItemFields As Variant
Dim reSponse
Dim myRange As Range
Dim intMaxSecCount As Integer
Dim intCount As Integer
Dim myDocOrientation
Dim myDocSectionNum
Dim mySourceOrientation, myDestinationOrientation, sCurSection,
sCurAppBrowser
On Error Resume Next
Dim ChkResults As Variant
If
IsMissing(ActiveDocument.CustomDocumentProperties("ValidTemplate"))
Then
MsgBox "This toolbar is restricted to Valid Corporate
templates only..."
Exit Sub
End If
MsgBox "Please note that when importing file data, the source
document may flash multiple times, this is normal...", vbInformation,
"SPS Information"
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
myDocSectionNum = Selection.Information(wdActiveEndSectionNumber)
myDocOrientation =
ActiveDocument.Sections(myDocSectionNum).PageSetup.Orientation
With dlgOpen
.Filters.Add "Word Document Format", "*.doc", 1
If .Show = -1 Then
.AllowMultiSelect = False
For Each vrtSelectedItemFields In .SelectedItems
strFileLoc = vrtSelectedItemFields
Next vrtSelectedItemFields
Else
End If
End With
Set dlgOpen = Nothing
If strFileLoc = "" Then
Else
' Initialise the range
Documents.Open FileName:=strFileLoc,
ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False,
PasswordDocument:="", _
PasswordTemplate:="", Revert:=False,
WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto,
XMLTransform:=""
intCount = 1
intMaxSecCount = ActiveDocument.Sections.Count
sCurAppBrowser =
Selection.Information(wdActiveEndSectionNumber)
Do While intCount <= intMaxSecCount
If intCount = 1 Then
'Do nothing
Else
Documents.Open FileName:=strFileLoc,
ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False,
PasswordDocument:="", _
PasswordTemplate:="", Revert:=False,
WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto,
XMLTransform:=""
End If
'Set the range to just the text in the section, but not
the section itself
'this avoids including the header and footer information
'and corrupting the document you're importing into...
Set myRange = ActiveDocument.Sections(intCount).Range
'check orientation
mySourceOrientation = myRange.PageSetup.Orientation
myRange.MoveEnd Unit:=wdParagraph, Count:=-1
myRange.Copy
ActiveDocument.Close (wdDoNotSaveChanges)
myDestinationOrientation =
ActiveDocument.PageSetup.Orientation
'MsgBox "Source: " & mySourceOrientation & " Destination:
" & myDestinationOrientation
If mySourceOrientation = wdOrientPortrait And
myDestinationOrientation = wdOrientPortrait Then
'MsgBox "Same Orientation"
Selection.PasteAndFormat (wdPasteDefault)
Selection.InsertBreak Type:=wdSectionBreakNextPage
ElseIf mySourceOrientation = wdOrientLandscape And
myDestinationOrientation = wdOrientLandscape Then
'MsgBox "Same Orientation"
Selection.PasteAndFormat (wdPasteDefault)
Selection.InsertBreak Type:=wdSectionBreakNextPage
ElseIf mySourceOrientation = wdOrientPortrait And
myDestinationOrientation = wdOrientLandscape Then
'Convert to Portrait
'MsgBox "Change Orientation"
sCurSection =
Selection.Information(wdActiveEndSectionNumber)
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveUp Unit:=wdLine, Count:=1
With Selection.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2.85)
.BottomMargin = CentimetersToPoints(2.54)
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.Gutter = CentimetersToPoints(0)
.SectionStart = wdSectionNewPage
With ActiveDocument
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
= False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
= False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections(sCurSection +
2).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections(sCurSection +
1).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
End With
End With
Selection.PasteAndFormat (wdPasteDefault)
With Application.Browser
.Target = wdBrowseSection
.Next
End With
ElseIf mySourceOrientation = wdOrientLandscape And
myDestinationOrientation = wdOrientPortrait Then
'Convert to landscape
'MsgBox "Change Orientation"
sCurSection =
Selection.Information(wdActiveEndSectionNumber)
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveUp Unit:=wdLine, Count:=1
With Selection.PageSetup
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(2.85)
.BottomMargin = CentimetersToPoints(2.85)
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.Gutter = CentimetersToPoints(0)
.SectionStart = wdSectionNewPage
With ActiveDocument
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
= False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
= False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections(sCurSection +
2).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections(sCurSection +
1).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
End With
End With
Selection.PasteAndFormat (wdPasteDefault)
With Application.Browser
.Target = wdBrowseSection
.Next
End With
End If
intCount = intCount + 1
Loop
Application.Browser.Target = wdBrowseComment
End If
reSponse = MsgBox("IMPORT COMPLETED. Note: As part of importing
this content into your document, a large amount of data has been
copied to the clipboard do you wish to delete this now?", vbYesNo,
"SPS Clipboard Warning")
If reSponse = vbYes Then
'Clear the clipboard
Call ClearClipBoard
End If
End Sub
