Re: Word VBA Copying Document Content from other documents issue by mablake
mablake
Thu Jan 24 01:59:55 PST 2008
On Jan 23, 10:27=A0pm, Mark B. <Ma...@discussions.microsoft.com> wrote:
> I am trying to code around a copy and paste issue with Word. =A0In that if=
you
> copy and paste the contents of a document that has multiple sections into =
an
> existing document, it brings with it header and footer information. =A0I k=
now
> if I manually select the content of each section in turn and past that,
> headers and footers remain unaffected. =A0I need to recreate this in code.=
=A0
> Currently I use:
>
> Sub InsertTextFromBoilerPlate()
> =A0 =A0 Dim dlgOpen As FileDialog
> =A0 =A0 Dim strFileLoc As String
> =A0 =A0 Dim vrtSelectedItemFields As Variant
>
> =A0 =A0 On Error Resume Next
> =A0 =A0 Dim ChkResults As Variant
>
> =A0 =A0 If IsMissing(ActiveDocument.CustomDocumentProperties("ValidTemplat=
e"))
> Then
> =A0 =A0 =A0 =A0 MsgBox "This toolbar is restricted to Valid Corporate temp=
lates
> only..."
> =A0 =A0 =A0 =A0 Exit Sub
> =A0 =A0 End If
>
> =A0 =A0 Set dlgOpen =3D Application.FileDialog(msoFileDialogFilePicker)
>
> =A0 =A0 With dlgOpen
> =A0 =A0 =A0 =A0 .Filters.Add "Word Document Format", "*.doc", 1
> =A0 =A0 =A0 =A0 If .Show =3D -1 Then
> =A0 =A0 =A0 =A0 =A0 =A0 .AllowMultiSelect =3D False
>
> =A0 =A0 =A0 =A0 =A0 =A0 For Each vrtSelectedItemFields In .SelectedItems
> =A0 =A0 =A0 =A0 =A0 =A0 =A0 =A0 strFileLoc =3D vrtSelectedItemFields
> =A0 =A0 =A0 =A0 =A0 =A0 Next vrtSelectedItemFields
> =A0 =A0 =A0 =A0 Else
> =A0 =A0 =A0 =A0 End If
> =A0 =A0 End With
> =A0 =A0 Set dlgOpen =3D Nothing
> =A0 =A0 If strFileLoc =3D "" Then
>
> =A0 =A0 Else
> =A0 =A0 =A0 =A0 Documents.Open FileName:=3DstrFileLoc, ConfirmConversions:=
=3DFalse, _
> =A0 =A0 =A0 =A0 ReadOnly:=3DFalse, AddToRecentFiles:=3DFalse, PasswordDocu=
ment:=3D"", _
> =A0 =A0 =A0 =A0 PasswordTemplate:=3D"", Revert:=3DFalse, WritePasswordDocu=
ment:=3D"", _
> =A0 =A0 =A0 =A0 WritePasswordTemplate:=3D"", Format:=3DwdOpenFormatAuto, X=
MLTransform:=3D""
>
> =A0 =A0 =A0 =A0 Selection.WholeStory
> =A0 =A0 =A0 =A0 Selection.Expand (wdMainTextStory)
> =A0 =A0 =A0 =A0 Selection.Copy
> =A0 =A0 =A0 =A0 ActiveDocument.Close
> =A0 =A0 =A0 =A0 Selection.PasteAndFormat (wdPasteDefault)
> =A0 =A0 =A0 =A0 'Selection.InsertFile FileName:=3DstrFileLoc, Range:=3D"",=
_
> =A0 =A0 =A0 =A0 'ConfirmConversions:=3DFalse, Link:=3DFalse, Attachment:=
=3DFalse
> =A0 =A0 End If
>
> End Sub
>
> I have experimented with selecting sections, but it always brings the Head=
er
> and Footer. =A0Does anyone know how to select the text within a section,
> meaning section(1) line 1 to last line of section? =A0Or another way of so=
lving
> 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 =3D Application.FileDialog(msoFileDialogFilePicker)
myDocSectionNum =3D Selection.Information(wdActiveEndSectionNumber)
myDocOrientation =3D
ActiveDocument.Sections(myDocSectionNum).PageSetup.Orientation
With dlgOpen
.Filters.Add "Word Document Format", "*.doc", 1
If .Show =3D -1 Then
.AllowMultiSelect =3D False
For Each vrtSelectedItemFields In .SelectedItems
strFileLoc =3D vrtSelectedItemFields
Next vrtSelectedItemFields
Else
End If
End With
Set dlgOpen =3D Nothing
If strFileLoc =3D "" Then
Else
' Initialise the range
Documents.Open FileName:=3DstrFileLoc,
ConfirmConversions:=3DFalse, _
ReadOnly:=3DFalse, AddToRecentFiles:=3DFalse,
PasswordDocument:=3D"", _
PasswordTemplate:=3D"", Revert:=3DFalse,
WritePasswordDocument:=3D"", _
WritePasswordTemplate:=3D"", Format:=3DwdOpenFormatAuto,
XMLTransform:=3D""
intCount =3D 1
intMaxSecCount =3D ActiveDocument.Sections.Count
sCurAppBrowser =3D
Selection.Information(wdActiveEndSectionNumber)
Do While intCount <=3D intMaxSecCount
If intCount =3D 1 Then
'Do nothing
Else
Documents.Open FileName:=3DstrFileLoc,
ConfirmConversions:=3DFalse, _
ReadOnly:=3DFalse, AddToRecentFiles:=3DFalse,
PasswordDocument:=3D"", _
PasswordTemplate:=3D"", Revert:=3DFalse,
WritePasswordDocument:=3D"", _
WritePasswordTemplate:=3D"", Format:=3DwdOpenFormatAuto,
XMLTransform:=3D""
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 =3D ActiveDocument.Sections(intCount).Range
'check orientation
mySourceOrientation =3D myRange.PageSetup.Orientation
myRange.MoveEnd Unit:=3DwdParagraph, Count:=3D-1
myRange.Copy
ActiveDocument.Close (wdDoNotSaveChanges)
myDestinationOrientation =3D
ActiveDocument.PageSetup.Orientation
'MsgBox "Source: " & mySourceOrientation & " Destination:
" & myDestinationOrientation
If mySourceOrientation =3D wdOrientPortrait And
myDestinationOrientation =3D wdOrientPortrait Then
'MsgBox "Same Orientation"
Selection.PasteAndFormat (wdPasteDefault)
Selection.InsertBreak Type:=3DwdSectionBreakNextPage
ElseIf mySourceOrientation =3D wdOrientLandscape And
myDestinationOrientation =3D wdOrientLandscape Then
'MsgBox "Same Orientation"
Selection.PasteAndFormat (wdPasteDefault)
Selection.InsertBreak Type:=3DwdSectionBreakNextPage
ElseIf mySourceOrientation =3D wdOrientPortrait And
myDestinationOrientation =3D wdOrientLandscape Then
'Convert to Portrait
'MsgBox "Change Orientation"
sCurSection =3D
Selection.Information(wdActiveEndSectionNumber)
Selection.InsertBreak Type:=3DwdSectionBreakNextPage
Selection.InsertBreak Type:=3DwdSectionBreakNextPage
Selection.MoveUp Unit:=3DwdLine, Count:=3D1
With Selection.PageSetup
.Orientation =3D wdOrientPortrait
.TopMargin =3D CentimetersToPoints(2.85)
.BottomMargin =3D CentimetersToPoints(2.54)
.LeftMargin =3D CentimetersToPoints(2)
.RightMargin =3D CentimetersToPoints(2)
.Gutter =3D CentimetersToPoints(0)
.SectionStart =3D wdSectionNewPage
With ActiveDocument
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
=3D False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
=3D False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).LinkToPrevious =3D False
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).LinkToPrevious =3D False
.Sections(sCurSection +
2).Headers(wdHeaderFooterPrimary).LinkToPrevious =3D False
.Sections(sCurSection +
1).Headers(wdHeaderFooterPrimary).LinkToPrevious =3D False
End With
End With
Selection.PasteAndFormat (wdPasteDefault)
With Application.Browser
.Target =3D wdBrowseSection
.Next
End With
ElseIf mySourceOrientation =3D wdOrientLandscape And
myDestinationOrientation =3D wdOrientPortrait Then
'Convert to landscape
'MsgBox "Change Orientation"
sCurSection =3D
Selection.Information(wdActiveEndSectionNumber)
Selection.InsertBreak Type:=3DwdSectionBreakNextPage
Selection.InsertBreak Type:=3DwdSectionBreakNextPage
Selection.MoveUp Unit:=3DwdLine, Count:=3D1
With Selection.PageSetup
.Orientation =3D wdOrientLandscape
.TopMargin =3D CentimetersToPoints(2.85)
.BottomMargin =3D CentimetersToPoints(2.85)
.LeftMargin =3D CentimetersToPoints(2)
.RightMargin =3D CentimetersToPoints(2)
.Gutter =3D CentimetersToPoints(0)
.SectionStart =3D wdSectionNewPage
With ActiveDocument
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
=3D False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection
=3D False
.Sections(sCurSection +
2).Footers(wdHeaderFooterPrimary).LinkToPrevious =3D False
.Sections(sCurSection +
1).Footers(wdHeaderFooterPrimary).LinkToPrevious =3D False
.Sections(sCurSection +
2).Headers(wdHeaderFooterPrimary).LinkToPrevious =3D False
.Sections(sCurSection +
1).Headers(wdHeaderFooterPrimary).LinkToPrevious =3D False
End With
End With
Selection.PasteAndFormat (wdPasteDefault)
With Application.Browser
.Target =3D wdBrowseSection
.Next
End With
End If
intCount =3D intCount + 1
Loop
Application.Browser.Target =3D wdBrowseComment
End If
reSponse =3D 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 =3D vbYes Then
'Clear the clipboard
Call ClearClipBoard
End If
End Sub