copy from word to word with macro

[zeljc]

i need a macro which copies text with its stiles and paragraphs and so on from one word document(WD1) to another word document(WD2). there are new stiles added for text in WD1 and they dont show up in WD2.
i made the code just to copy text without stiles.

 

[PHV]

Have you tried to play with the CopyFormat and PasteFormat methods ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[fumei]

PasteFormat will bring over the format, but it NOT bring over the style. Text pasted into a document will either:

1. use the available Styles in that document (normal paste); OR
2. be manually formatted into the source format (pasteformat).

You can either:

1. make the Styles of WD1 in WD2; (probably easiest)
2. manually copy the Styles of WD1 into WD2 before moving the text; (not that hard)
3. copy the Styles of WD1 into WD2 by code. (a little tricky, but not extremely difficult)

Gerry

 

[zeljc]

there is a problem doing it manually. there is over 1000 documents to do every week. so that is why i need it by script. so no. 3 by gerry would be probably ok. if you -gerry can help with some code it would be great.

first i will try to copy all styles(manually) and then by script move text from WD1 to WD2. i will also try to move the styles by code, because i'm not sure they are always the same in every document, but i'll check.

thx gerry and MI5

 

[zeljc]

pardon MI5 -> PHV

 

[zeljc]

i have tried moving styles by code and it does move the styles, but after i run the other part of the code(copy text) and try to open the document it askes me "select the encoding that makes your document readable". i tried selecting almost every one of them but stil doesnt work. it puts out some japanese encoding or unreadable signs.

 

[zeljc]

'here is the code

filenum1 = FreeFile
Filename = "C:\WD1.doc"
Open Filename For Input Access Read As filenum1

filenum2 = FreeFile
Filename2 = "C:\WD2.doc"
Open Filename2 For Append As filenum2

'1. first the style
'********************************
1. here gives the error: "argument not optional" for CopyStylesFromTemplate
' if whit out the if statement, then it gives: "bad file name" at Documents("C:\WD2.doc").CopyStylesFromTemplate
'********************************

If Documents(filenum2).CopyStylesFromTemplate.Count > 0 Then
Documents("C:\WD2.doc").CopyStylesFromTemplate _
Template:="C:\WD1.doc" 'and WD1.dot
End If

'*******************************
2. if i put only this part it creates the WD2, but it askes me
"select the encoding that makes your document readable"
and it is not readable anyway
'*******************************

' 2. second copy text
While Not EOF(filenum1)

Line Input #filenum1, line
Print #filenum2, line
Wend

Close filenum1
Close filenum2

 

[zeljc]

i came up with a new idea. copy files manualy. all styles too into a template which already has stiles as they should be + more, and just reapply the styles.
i have tried with
ActiveDocument.Styles(wdStyleHeading2).Font.Bold = True
ActiveDocument.Styles(wdStyleHeading2).Font.Name = "Arial"
ActiveDocument.Styles(wdStyleHeading2).Font.Size = 20

but there is a lot more of attributes. for example if i have a look at heading2 style it's like this:
---------------------
heading2: fontDefault) Arial, 20 pt, Bold, German(Germany), Left, Line apacing : single, Space After: 12 pt, Widow/Orphan control, Page break before, Level2
---------------------
i have written those three, but cant find it for the rest. help if can. this one has bigger priority. thx

 

[zeljc]

solution my way if anybody is interested:

*-* with macro copied data from other WD documents

*-* styles are copied also with one exception: only one text with Heading2 wont work(still don't get it, it wont work even with
ActiveDocument.Styles(wdStyleHeading2)_
.ParagraphFormat.PageBreakBefore = True (here i have tried first putting it on false and then on true. even more then once)

and activeDocument.updateStyles)

*-* insert index and table

here is the code. the important thing is that all the documents from which you attempt to copy, have to be open and opened in reversed order. for example if you want to copy from 1.doc, 2.doc, 3.doc, you open them : 3, 2, 1. hope it helps anyone.

dim myDocument as string

myDocument = "C:\WD.doc"

'copy data

For Each wdDoc In Documents

Windows(wdDoc).Activate
Selection.WholeStory
Selection.Copy
Windows(myDocument).Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.InsertBreak Type:=wdPageBreak

Next aDoc

' make Tables Of Contents

Set myRange = ActiveDocument.Range(Start:=0, End:=0)
ActiveDocument.TablesOfContents.Add Range:=myRange, _
UseFields:=False, UseHeadingStyles:=True, _
LowerHeadingLevel:=3, _ ' bottom level is 3
UpperHeadingLevel:=1 ' top level is 1


if anybody knows why it wont apply Heading2, please help.
thx

 

[zeljc]

i have found the solution. if interested, mail me.

 

[zeljc]

stil need help with my macro. now i'm optimizing it. i have done it the way it should be, but it is too long. i came from 884 lines down to 444 lines of code. before, it send out the error, the microsoft alert: Send/Don't Send report. dont know why.(this happend when i ran it at: open the template. i inserted AutoNew module and run 4 macros in it. it copies the documents, sets table of contents, sets styles and reapplies styles)

so i optimized it a bit.
here is where it crashes:

For Each styyle In docStyyle.Styles
If styyle.InUse = True Then
With docStyyle.Content.Find
.ClearFormatting
.Style = styyle ' ----!!!!!!------ ERROR
If .Found = True Then
With docStyyle.Content.Find
.Replacement.ClearFormatting
.Replacement.Style = styyle
.Forward = True
.Wrap = wdFindContinue
.Format = True
End With
End If
End With
Selection.Find.Execute Replace:=wdReplaceAll
End If
Next styyle

ERROR: Item with specified name does not exist

i have tried a similar one from microsoft visual bacis help just for example and it crashes also at that point.

here is what my code looked like before884 lines)

' course acronym slug - the style

Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Course Acronym Slug")
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Course Acronym Slug")

With Selection.Find
.Forward = True
.Wrap = wdFindContinue
.Format = True
End With

Selection.Find.Execute Replace:=wdReplaceAll

and so on for over 10 of them so i had to optimize it.
-------------------------------------------------------

** the other problem:

as said the macro starts at opening the template. it copies the files, sets table of contents, sets styles and reapplies styles.(or it should)
i run 4 macros:
1.) copy files
2.) table of contents
3.) set styles
4.) apply styles (the first problem)

example for 3.) (this one is also too long. also for over 10 of them - styles) this too needs optimizing.(the other problem)
'---------------------------------------------------
' course acronym slug

With ActiveDocument.Content.Find.Style = "Course Acronym Slug"
If ActiveDocument.Content.Find.Style = True Then

With ActiveDocument.Styles("Course Acronym Slug").Font
.Name = "Arial"
.Size = 16
.Bold = True
.Italic = False
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Scaling = 100
.Kerning = 0
.Animation = wdAnimationNone
End With
With ActiveDocument.Styles("Course Acronym Slug").ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(12.65)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceExactly
.LineSpacing = 19
.Alignment = wdAlignParagraphRight
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = True
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 4
.DistanceFromRight = 4
.Shadow = False
End With
End With
ActiveDocument.Styles("Course Acronym Slug"). _
NoSpaceBetweenParagraphsOfSameStyle = False
ActiveDocument.Styles("Course Acronym Slug").ParagraphFormat.TabStops. _
ClearAll
ActiveDocument.Styles("Course Acronym Slug").ParagraphFormat.TabStops.Add _
Position:=CentimetersToPoints(4), Alignment:=wdAlignTabRight, Leader:= _
wdTabLeaderSpaces
End If
End With

it can be a bit optimized. not using False statements, but it is stil long.

help if can, thx.

 

[fumei]

Do you need ALL the lines regarding the attributes????

Gerry
My paintings and sculpture

 

[zeljc]

well sometimes yes sometimes no. i don't get it why. i'm trying without false attributes. it works for now. so i will leave it at that.
there is still the first problem. don't know how to shorten that one.

problem #3:
now i'm trying to start renumbering after every Heading 2.

what it looks like:

Heading 2
text
step 1
step 2
Heading 3
step 3
text
Heading 3
Heading 2
step 4
step 5

what it should look like:

Heading 2
text
step 1
step 2
Heading 3
step 3
text
Heading 3
Heading 2
step 1
step 2


don't need the restart numbering in Heading 2 where you can select in attributes. because Heading 3 is on it's own .

i've been trying this next thing, but it doesn't work. if i find it manually and then restart, it works. but there is to many of these documents to be doing it that way, so that is why i need the macro for this:

With ActiveDocument.Content.Find
.ClearFormatting
.Style = wdStyleHeading2
Do While .Execute(FindText:="", Forward:=True, Format:=True) = True
With .Parent
With ListGalleries(wdNumberGallery).ListTemplates(6).ListLevels(1)
.LinkedStyle = "List Steps"
.NumberFormat = "Step %1"
.ResetOnHigher = 0
.StartAt = 1
End With
ListGalleries(wdNumberGallery).ListTemplates(6).Name = ""
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
wdNumberGallery).ListTemplates(6), ContinuePreviousList:=False, ApplyTo:= _
wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
.StartOf Unit:=wdParagraph, Extend:=wdMove
.Move Unit:=wdParagraph, Count:=1
End With
Loop
End With

thanks

 

[zeljc]

solved

 

[fumei]

Then please post that solution. Please also use the code tags. Thanks.

Gerry
My paintings and sculpture

 

[zeljc]

well #3 problem is solved. hope i didn't mislead anybody. still trying to solve those above. if you still need the #3 here it is(use your own number in ListTemplates(#)):


sub renum()

Application.ScreenUpdating = False

'find first heading 2
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 2")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
End With
Selection.Find.Execute
Selection.MoveDown Unit:=wdParagraph, Count:=1

'find the rest of H2 and List Steps, and renumber
With Selection.Find
Do While .Execute(FindText:="", Format:=True, Forward:=True, Wrap:=False) = True
Selection.MoveDown Unit:=wdParagraph, Count:=1
Selection.Find.Style = ActiveDocument.Styles("List Steps")
With Selection.Find
If .Execute(FindText:="") = True Then
ListGalleries(wdNumberGallery).ListTemplates(6).ListLevels(1).StartAt = 1
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
wdNumberGallery).ListTemplates(6), ContinuePreviousList:=False, _
ApplyTo:=wdListApplyToWholeList
Selection.MoveDown Unit:=wdParagraph, Count:=1
End If
End With
Selection.Find.Style = ActiveDocument.Styles("Heading 2")
Loop
End With

end sub