#16
|
|||
|
|||
Hi Paul,
Thanks for the Code. I was surprised to see it, I did not expect it thanks for your time. Sorry I missed that part about the appendix, it is same as the others they need to be copied to a new document and deleted. This also applies to the Reference section. I did run your new code. It creates an output folder and creates new files, which is what I wanted. But when creating tables all tables are joint to one another, and are copied out of range on the page (not within the margins) I would prefer them to be separated with the section number and titles copied too. Note: some document are from earlier version of MS (i.e. word 2003 with file ext.doc and word 2007 with file ext.docx) will this cause any problems. FYI all documents have a Title (heading) page followed by the Revision History (RH) pages which are formated as table, then followed by the TOC. This Title page and RH is not required to be copied. (The code I sent earlier “Sub MoveTablesToNewDocument” did not copy title page and RH, but copied the tables along with table number and the titles). Thanks FLDS |
#17
|
||||
|
||||
Hi flds,
Quote:
Quote:
Quote:
Quote:
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#18
|
|||
|
|||
Thanks Paul for your response.
Quote 1 - Comment Reply -REFERENCES – section starts with “Heading 1” style, it comes before the appendix section. -Appendix – is a section with “Appendix Title” Style, (i.e. it starts as Appendix A, Appendix B….etc.) Its not an upper case. Quote 2 - Comment Reply Sorry, I used a wrong statement, I meant that the individual tables are not separated with blank rows (tables without titles). It would be helpful if you could include 3 blank rows between tables. If possible could I have both options using comment block in the code for, keeping the section break and Deleting the section break, I could select which one would run best. Table ref and desc. use the “Table Caption” Style for tables before the Reference and Appendix section. Sometimes tables are also included in Appendix and Reference section, using “Appx Table Caption” Style. Table titles appear before the tables. Quote 4 - Comment Reply Yes, modifying the code to handle the pages before the TOC would be helpful. Is it ok, if I ask for 2 more simple requirements relating to the same documents. Based on the concept as the last code. I have found one code and the other needs to be created. Thanks FLDS |
#19
|
||||
|
||||
Hi flds,
Try the following. Code:
Sub ParseDocs() Application.ScreenUpdating = False Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, Sctn As Section, Rng As Range Dim DocSrc As Document, DocTxt As Document, DocTbl As Document, DocApp As Document, DocRef As Document 'Call the GetFolder Function to determine the folder to process strInFold = GetFolder If strInFold = "" Then Exit Sub strFile = Dir(strInFold & "\*.doc", vbNormal) 'Check for documents in the folder - exit if none found If strFile <> "" Then strOutFold = strInFold & "\Output" 'Test for an existing outpfolder & create one if it doesn't already exist If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold strFile = Dir(strInFold & "\*.doc", vbNormal) 'Process all documents in the chosen folder While strFile <> "" Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False) With DocSrc 'Delete everything before the first Table Of Contents in the source document If .TablesOfContents.Count <> 0 Then Set Rng = .TablesOfContents(1).Range Rng.Start = .Range.Start Rng.Delete End If 'Delete any other Tables Of Contents in the source document For Each TOC In .TablesOfContents TOC.Delete Next 'Convert all fields in the source document to plain text .Fields.Unlink 'Convert all non-breaking hyphens in the source document to ordinary hyphens With Content.Find .ClearFormatting .Replacement.ClearFormatting .Text = "^~" .Replacement.Text = "-" .Execute Replace:=wdReplaceAll End With 'Check for tables in the source document If .Tables.Count > 0 Then 'If there are any tables in the source document, make a copy of the document .Range.Copy ' Create a new document for the tables Set DocTbl = Documents.Add(Visible:=False) 'Process the new document Call MakeTableDoc(DocTbl) 'Delete all tables in the source document For Each Tbl In .Tables Tbl.Delete Next End If 'Check for appendices in the source document For Each Sctn In .Sections If UCase(Sctn.Range.Words.First) = "APPENDIX" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first appendices Section to the end of the 'source document and paste it into a new appendices document Rng.Cut Set DocApp = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocApp) Exit For End If Next 'Check for references in the source document For Each Sctn In .Sections If UCase(Sctn.Range.Words.First) = "REFERENCES" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first references Section to the end of the 'source document and paste it into a new references document Rng.Cut Set DocRef = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocRef) Exit For End If Next Call Cleanup(.Range) 'String variable for the output filenames strOutFile = strOutFold & "\" & Split(.Name, ".")(0) 'Copy whatever's left in the source document and paste it into a new text document .Range.Copy Set DocTxt = Documents.Add(Visible:=False) With DocTxt .Range.Paste 'Save and close the text document .SaveAs FileName:=strOutFile & "-Text", AddTorecentFiles:=False .Close End With Set DocTxt = Nothing 'Save and close the references document If Not DocRef Is Nothing Then DocRef.SaveAs FileName:=strOutFile & "-References", AddTorecentFiles:=False DocRef.Close Set DocRef = Nothing End If 'Save and close the tables document If Not DocTbl Is Nothing Then DocTbl.SaveAs FileName:=strOutFile & "-Tables", AddTorecentFiles:=False DocTbl.Close Set DocTbl = Nothing End If 'Save and close the appendices document If Not DocApp Is Nothing Then DocApp.SaveAs FileName:=strOutFile & "-Appendices", AddTorecentFiles:=False DocApp.Close Set DocApp = Nothing End If 'Close the source document without saving the changes we've made to it .Close SaveChanges:=False End With strFile = Dir() Wend Set Rng = Nothing: Set DocSrc = Nothing Application.ScreenUpdating = True End Sub Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String On Error Resume Next GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path End Function Sub MakeTableDoc(DocTbl As Document) Dim Sctn As Section, Para As Paragraph, Rng As Range With DocTbl .Range.Paste 'Delete any Sections with no tables in the tables document For Each Sctn In .Sections If Sctn.Range.Tables.Count = 0 Then Sctn.Range.Delete Else On Error Resume Next If Sctn.PageSetup.Orientation = Sctn.Range.Previous.PageSetup.Orientation Then Sctn.Range.Previous.Characters.Last.Delete End If End If Next 'Check all paragraphs not in tables in the tables document For Each Para In .Paragraphs With Para Set Rng = .Range On Error Resume Next With Rng If .Information(wdWithInTable) = False Then If .Next.Paragraphs.First.Range.Information(wdWithInTable) = False Then 'Delete any paragraphs not followed by a table in the tables document .Delete Else 'Keep table captions, if present, and ensure there are three paragraphs 'between tables in the tables document If InStr(.Style, "Table Caption") = 0 Then .End = .End - 1 .Text = vbNullString End If .InsertBefore vbCr & vbCr End If End If End With End With Next End With Set Rng = Nothing End Sub Sub NewDoc(NewDoc As Document) With NewDoc .Range.Paste Call Cleanup(.Range) End With End Sub Sub Cleanup(Rng As Range) With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Text = "^b" .Replacement.Text = "" .Execute Replace:=wdReplaceAll End With End Sub As for: Quote:
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#20
|
|||
|
|||
Thanks for the revised code.
Text Output feedback – is fine. Table Output feedback - output includes blank pages. Otherwise it is all good. REFERENCES Output feedback – Everything under References is being copied Figures, pictures (not required to be deleted) also the tables that were included in the tables doc. and also the appendixes are being copied. Appendix Output feedback - No output. I assume the line in the code “If UCase(Sctn.Range.Words.First) = "APPENDIX" Then” may be the cause. Upper or Lower case letters. In the main document it is as Appendix A, Appendix B etc. Thanks for the reply for the 2 other requirements, these may be quite simple I guess to create. Both codes based on the same concept of your Code “ The code includes folder navigation and code to produce an 'Output' folder below that for holding the output files. All documents in the selected folder will be processed automatically.”
This outputs the outline of section numbers and headings only. I would like to include this in your Code. I tried to include this in your code. When I run this code the sheet is created but could not include it in the output folder. I hope this will not be a hassle. Thanks for your precious time. |
#21
|
||||
|
||||
Hi flds,
The code creates the tables, appendices, references & text output documents in that order. As it goes, tables in the source document (should) get deleted, then appendices (should) get deleted followed by references. If a problem occurs early in the chain, the effects will be seen further down. Hence, tables appearing where they shouldn't, etc. Re blank pages in the tables document, that suggests your source document has manual page breaks as well as Section breaks. Please confirm. If so, I can modify the code to remove them. The code: Code:
'Delete all tables in the source document For Each Tbl In .Tables Tbl.Delete Next Re appendices document, the lack of output suggests the first word of the relevant Section is not 'Appendix'. The 'If UCase(Sctn.Range.Words.First) = "APPENDIX" Then' test captures any combination of upper/lower case, by converting everything to upper case and comparing on that basis. Re references document, the inclusion of the appendices is due to whatever causes the appendices not to be extracted beforehand. Re the 'Design Requirements', does this heading begin an new Section? How does one detect when that portion of the document has ended (eg end of the Section in which the heading appears, start of 'references' Section, something else)? I have no idea which code from the link you posted relates to this - it all seems to be directed at converting vba code to Visual Studio.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#22
|
|||
|
|||
Hi Paul,
Thanks for your reply. "Re blank pages in the tables document, that suggests your source document has manual page breaks as well as Section breaks. Please confirm. If so, I can modify the code to remove them. The code:" Yes there may or may not be manual page breaks and section breaks. They need to be removed. "should delete all tables from the source document once the tables document is created and before going on to the appendices document's creation. If any remain when the appendices & refernces documents are created, that suggests there are tables in textboxes or something such. Please confirm." As far as I see I doubt that tables are in text boxes, the documents I opened i have not come across any. "Re appendices document, the lack of output suggests the first word of the relevant Section is not 'Appendix'. The 'If UCase(Sctn.Range.Words.First) = "APPENDIX" Then' test captures any combination of upper/lower case, by converting everything to upper case and comparing on that basis." Appendix A, Appendix B, Appendix C etc. are separate in a line, following lines contain the text. "Re references document, the inclusion of the appendices is due to whatever causes the appendices not to be extracted beforehand." Appendixes is the last section in the documents. I dont know why appendix is copied under references. "Re the 'Design Requirements', does this heading begin an new Section? How does one detect when that portion of the document has ended (eg end of the Section in which the heading appears, start of 'references' Section, something else)? " Yes it begins a new section (ie. 2. DESIGN REQUIREMENTS) The new section will start as section 3. ???? "I have no idea which code from the link you posted relates to this - it all seems to be directed at converting vba code to Visual Studio." I mentioned it as Tip# 5, anyway I have copied the code below. Tip #5: Convert Existing VBA Code Code: Code:
PublicSub CreateOutline() Dim docOutline As Word.Document Dim docSource As Word.Document Dim rng As Word.Range Dim astrHeadings AsVariant Dim strText AsString Dim intLevel AsInteger Dim intItem AsInteger Set docSource = ActiveDocument Set docOutline = Documents.Add ' Content returns only the ' main body of the document, not ' the headers and footer. Set rng = docOutline.Content astrHeadings = _ docSource.GetCrossReferenceItems(wdRefTypeHeading) For intItem = LBound(astrHeadings) To UBound(astrHeadings) ' Get the text and the level. strText = Trim$(astrHeadings(intItem)) intLevel = GetLevel(CStr(astrHeadings(intItem))) ' Add the text to the document. rng.InsertAfter strText & vbNewLine ' Set the style of the selected range and ' then collapse the range for the next entry. rng.Style = "Heading " & intLevel rng.Collapse wdCollapseEnd Next intItem EndSub PrivateFunction GetLevel(strItem AsString) AsInteger ' Return the heading level of a header from the ' array returned by Word. ' The number of leading spaces indicates the ' outline level (2 spaces per level: H1 has ' 0 spaces, H2 has 2 spaces, H3 has 4 spaces. Dim strTemp AsString Dim strOriginal AsString Dim intDiff AsInteger ' Get rid of all trailing spaces. strOriginal = RTrim$(strItem) ' Trim leading spaces, and then compare with ' the original. strTemp = LTrim$(strOriginal) ' Subtract to find the number of ' leading spaces in the original string. intDiff = Len(strOriginal) - Len(strTemp) GetLevel = (intDiff / 2) + 1 EndFunction FLDS |
#23
|
||||
|
||||
Hi flds,
Quote:
The code in your last post seems intended to produce a document with a list of headings. Is that substantively different to what you'd get by simply exporting the Table of Contents as plain text to another document? How much of the source document should be included? If it's run before the Table of Contents is deleted and any of the sub-documents are created, you'll something based on the entire source document, but if it's run afterwards, you'll only get what's in the 'text' document. In between, you could get something that, say, excludes any headings on the Title page and in the Revision History.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#24
|
|||
|
|||
Hi Paul
"OK, but does the first appendix Section begin with the word 'Appendix', or is there something else on the page before that (eg an empty paragraph or some other text)? The code I've provided is, as I've said before, predicated on the the first word in the first appendix Section being the word 'Appendix' (in any upper/lower case form)." Yes the first word bigins with Aappendix. Paul, regarding the OUTLINE code,I could run this code prior to running your code. In this case I will have the complete doc's TOC. "Is that substantively different to what you'd get by simply exporting the Table of Contents as plain text to another document?" It could be but I am not sure if the TOC actually includes all the levels of the sectons and sub sections, the code I send does. "How much of the source document should be included?" Complete doc TOC (before deleting) Only the section headings as it does when I run the Outline code. "If it's run before the Table of Contents is deleted and any of the sub-documents are created, you'll something based on the entire source document" The code I attached is a separate code by itself. I have merged it with part of your code (modified a bit). I tried running the code, it works, but does not add the new sheet to the output folder. I have commented out some DIM and some may be duplicates. If you have the time could you please review it. Code:
Sub Outline() Application.ScreenUpdating = False Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String ‘Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, _ ‘ Sctn As Section, Rng As Range Dim DocSrc As Document, DocTOC As Document 'Call the GetFolder Function to determine the folder to process strInFold = GetFolder If strInFold = "" Then Exit Sub strFile = Dir(strInFold & "\*.doc", vbNormal) 'Check for documents in the folder - exit if none found If strFile <> "" Then strOutFold = strInFold & "\Output" 'Test for an existing outpfolder & create one if it doesn't already exist If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold strFile = Dir(strInFold & "\*.doc", vbNormal) 'Process all documents in the chosen folder While strFile <> "" Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False) With DocSrc ‘ I HAVE ADDED THIS CODE BELOW WHICH I SENT YOU ‘PublicSub CreateOutline()Dim docOutline As Word.Document Dim docSource As Word.Document Dim rng As Word.Range Dim astrHeadings AsVariant Dim strText AsString Dim intLevel AsInteger Dim intItem AsInteger Set docSource = ActiveDocument Set docOutline = Documents.Add ' Content returns only the ' main body of the document, not ' the headers and footer. Set rng = docOutline.Content astrHeadings = _ docSource.GetCrossReferenceItems(wdRefTypeHeading) For intItem = LBound(astrHeadings) To UBound(astrHeadings) ' Get the text and the level. strText = Trim$(astrHeadings(intItem)) intLevel = GetLevel(CStr(astrHeadings(intItem))) ' Add the text to the document. rng.InsertAfter strText & vbNewLine ' Set the style of the selected range and ' then collapse the range for the next entry. rng.Style = "Heading " & intLevel rng.Collapse wdCollapseEnd Next intItem EndSub PrivateFunction GetLevel(strItem AsString) AsInteger ' Return the heading level of a header from the ' array returned by Word. ' The number of leading spaces indicates the ' outline level (2 spaces per level: H1 has ' 0 spaces, H2 has 2 spaces, H3 has 4 spaces. Dim strTemp AsString Dim strOriginal AsString Dim intDiff AsInteger ' Get rid of all trailing spaces. strOriginal = RTrim$(strItem) ' Trim leading spaces, and then compare with ' the original. strTemp = LTrim$(strOriginal) ' Subtract to find the number of ' leading spaces in the original string. intDiff = Len(strOriginal) - Len(strTemp) GetLevel = (intDiff / 2) + 1 EndFunction ‘ FOLLOWING IS PART OF YOUR CODE 'String variable for the output filenames strOutFile = strOutFold & "\" & Split(.Name, ".")(0) 'Copy whatever's left in the source document and paste it into a new text document .Range.Copy Set DocTOC = Documents.Add(Visible:=False) With DocTOC .Range.Paste 'Save and close the text document .SaveAs FileName:=strOutFile & "-TOC", AddTorecentFiles:=False .Close End With Set DocTOC = Nothing 'Close the source document without saving the changes we've made to it .Close SaveChanges:=False End With strFile = Dir() Wend Set Rng = Nothing: Set DocSrc = Nothing Application.ScreenUpdating = True End Sub Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String On Error Resume Next GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path End Function I hope what I have modified is correct. Thanks FLDS |
#25
|
||||
|
||||
Hi flds,
Try: Code:
Sub ParseDocs() Application.ScreenUpdating = False Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, Sctn As Section, Rng As Range Dim DocSrc As Document, DocOutline As Document, DocTxt As Document, DocTbl As Document Dim DocApp As Document, DocRef As Document 'Call the GetFolder Function to determine the folder to process strInFold = GetFolder If strInFold = "" Then Exit Sub strFile = Dir(strInFold & "\*.doc", vbNormal) 'Check for documents in the folder - exit if none found If strFile <> "" Then strOutFold = strInFold & "\Output\" 'Test for an existing outpfolder & create one if it doesn't already exist If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold strFile = Dir(strInFold & "\*.doc", vbNormal) 'Process all documents in the chosen folder While strFile <> "" Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False) With DocSrc Set DocOutline = Documents.Add(Visible:=False) Call CreateOutline(DocSrc, DocOutline) 'Delete everything before the first Table Of Contents in the source document If .TablesOfContents.Count <> 0 Then Set Rng = .TablesOfContents(1).Range Rng.Start = .Range.Start Rng.Delete End If 'Delete any other Tables Of Contents in the source document For Each TOC In .TablesOfContents TOC.Delete Next 'Convert all fields in the source document to plain text .Fields.Unlink With Content.Find .ClearFormatting .Replacement.ClearFormatting 'Convert non-breaking hyphens to ordinary hyphens .Text = "^~" .Replacement.Text = "-" .Execute Replace:=wdReplaceAll 'Delete manual page breaks .Text = "^m" .Replacement.Text = "" .Execute Replace:=wdReplaceAll End With 'Check for tables in the source document If .Tables.Count > 0 Then 'If there are any tables in the source document, make a copy of the document .Range.Copy ' Create a new document for the tables Set DocTbl = Documents.Add(Visible:=False) 'Process the new document Call MakeTableDoc(DocTbl) End If 'Delete all tables in the source document For Each Tbl In .Tables Tbl.Delete Next 'Check for appendices in the source document For Each Sctn In .Sections If UCase(Trim(Sctn.Range.Words.First)) = "APPENDIX" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first appendices Section to the end of the 'source document and paste it into a new appendices document Rng.Cut Set DocApp = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocApp) Exit For End If Next 'Check for references in the source document For Each Sctn In .Sections If UCase(Trim(Sctn.Range.Words.First)) = "REFERENCES" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first references Section to the end of the 'source document and paste it into a new references document Rng.Cut Set DocRef = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocRef) Exit For End If Next 'Check for design requirements in the source document For Each Sctn In .Sections If UCase(Sctn.Range.Sentences.First) Like "#*DESIGN REQUIREMENT*" Then Set Rng = Sctn.Range Rng.End = .Range.End 'Cut the from the start of the first references Section to the end of the 'source document and paste it into a new references document Rng.Cut Set DocDesReq = Documents.Add(Visible:=False) 'Process the new document Call NewDoc(DocDesReq) Exit For End If Next Call Cleanup(.Range) 'String variable for the output filenames strOutFile = strOutFold & Split(.Name, ".")(0) 'Copy whatever's left in the source document and paste it into a new text document .Range.Copy Set DocTxt = Documents.Add(Visible:=False) With DocTxt .Range.Paste 'Save and close the text document .SaveAs FileName:=strOutFile & "-Text", AddTorecentFiles:=False .Close End With Set DocTxt = Nothing 'Save and close the Outline document With DocOutline .SaveAs FileName:=strOutFile & "-Outline", AddTorecentFiles:=False .Close End With 'Save and close the tables document If Not DocTbl Is Nothing Then DocTbl.SaveAs FileName:=strOutFile & "-Tables", AddTorecentFiles:=False DocTbl.Close Set DocTbl = Nothing End If 'Save and close the appendices document If Not DocApp Is Nothing Then DocApp.SaveAs FileName:=strOutFile & "-Appendices", AddTorecentFiles:=False DocApp.Close Set DocApp = Nothing End If 'Save and close the references document If Not DocRef Is Nothing Then DocRef.SaveAs FileName:=strOutFile & "-References", AddTorecentFiles:=False DocRef.Close Set DocRef = Nothing End If 'Save and close the design requirements document If Not DocDesReq Is Nothing Then DocDesReq.SaveAs FileName:=strOutFile & "-Design Requirements", AddTorecentFiles:=False DocDesReq.Close Set DocDesReq = Nothing End If 'Close the source document without saving the changes we've made to it .Close SaveChanges:=False End With strFile = Dir() Wend Set Rng = Nothing: Set DocOutline = Nothing: Set DocSrc = Nothing Application.ScreenUpdating = True End Sub Code:
Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String On Error Resume Next GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path End Function Code:
Sub MakeTableDoc(DocTbl As Document) Dim Sctn As Section, Para As Paragraph, Rng As Range With DocTbl .Range.Paste 'Delete any Sections with no tables in the tables document For Each Sctn In .Sections If Sctn.Range.Tables.Count = 0 Then Sctn.Range.Delete Else On Error Resume Next 'Delete any Section breaks with no effect on page orientation If Sctn.PageSetup.Orientation = Sctn.Range.Previous.PageSetup.Orientation Then Sctn.Range.Previous.Characters.Last.Delete End If End If Next 'Check all paragraphs not in tables in the tables document For Each Para In .Paragraphs With Para Set Rng = .Range On Error Resume Next With Rng If .Information(wdWithInTable) = False Then If .Next.Paragraphs.First.Range.Information(wdWithInTable) = False Then 'Delete any paragraphs not followed by a table in the tables document .Delete Else 'Keep table captions, if present, and ensure there are three paragraphs 'between tables in the tables document If InStr(.Style, "Table Caption") = 0 Then .End = .End - 1 .Text = vbNullString End If .InsertBefore vbCr & vbCr End If End If End With End With Next 'Call Cleanup(.Range) End With Set Rng = Nothing End Sub Code:
Sub NewDoc(NewDoc As Document) With NewDoc .Range.Paste Call Cleanup(.Range) End With End Sub Code:
Sub Cleanup(Rng As Range) With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Text = "^b" .Replacement.Text = "" .Execute Replace:=wdReplaceAll End With End Sub Code:
Sub CreateOutline(DocSrc As Document, DocOutline As Document) Dim Rng As Range, astrHeadings As Variant, strText As String Dim intLevel As Integer, intItem As Integer ' Content returns only the main body of the document, not ' the headers and footer. Set Rng = DocOutline.Content astrHeadings = DocSrc.GetCrossReferenceItems(wdRefTypeHeading) For intItem = LBound(astrHeadings) To UBound(astrHeadings) ' Get the text and the level. strText = Trim$(astrHeadings(intItem)) intLevel = GetLevel(CStr(astrHeadings(intItem))) ' Add the text to the document. Rng.InsertAfter strText & vbNewLine ' Set the style of the selected range and ' then collapse the range for the next entry. Rng.Style = "Heading " & intLevel Rng.Collapse wdCollapseEnd Next intItem End Sub Code:
Private Function GetLevel(strItem As String) As Integer ' Return the heading level of a header from the array returned by Word. ' The number of leading spaces indicates the outline level '(2 spaces per level): H1 has 0 spaces, H2 has 2 spaces, H3 has 4 spaces. Dim strTemp As String, strOriginal As String, intDiff As Integer ' Get rid of all trailing spaces. strOriginal = RTrim$(strItem) ' Trim leading spaces, and then compare with the original. strTemp = LTrim$(strOriginal) ' Subtract to find the number of leading spaces in the original string. intDiff = Len(strOriginal) - Len(strTemp) GetLevel = (intDiff / 2) + 1 End Function
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#26
|
|||
|
|||
Hi Paul,
Thanks for the code I tried it. It still requires a few fixes. Following is the feedback from the code I ran. - Text – Output is fine, if not for the what happens in the output of “Design Requirement” - Tables are fine - References is fine, only thing is that it includes pictures and figures, need to be deleted. Pictures and figures are not required in any of the output folder. - Outline is fine. - Appendix is fine - Design Requirements – output gives me all the section, it should only copy the section, “Design Requirements” (i.e Section 4 and section 8, in the example below). It also re-numbers the section, which should not happen. The section numbers should remain the same. For example. I have sections as follows 1. Introduction, 2. System Description , 3. Material Description, 4. Design Requirements, 5. Code and Standards, 6. Safety Requirements, 7. Operations, 8. Component Design Requirements, 9. Overpressure Protection, 10. References and followed by Appendices. If the picture and figures are deleted and “Design Requirements” part is fixed then this is exactly what I want. I hope you will be able to do this fix. If you need more clarification let me know. Thanks for your time and affords. |
#27
|
|||
|
|||
Hi Paul,
Sorry, I missed to mention this. The macro halts at, and so I had to make it as a comment block. With Content.Find ' .ClearFormatting ' .Replacement.ClearFormatting ' 'Convert non-breaking hyphens to ordinary hyphens ' .Text = "^~" ' .Replacement.Text = "-" ' .Execute Replace:=wdReplaceAll ' 'Delete manual page breaks ' .Text = "^m" ' .Replacement.Text = "" ' .Execute Replace:=wdReplaceAll ' End With Thanks FLDS |
#28
|
||||
|
||||
Hi flds,
Quote:
Quote:
If the numbering issue is simply with the number assigned to the 'Design Requirements' heading and you're using Heading Styles for that, it should be possible for Word to tell that document to start the numbering from whatever number the 'Design Requirements' heading had in the source document. Coding for that would take a bit of working out, which I can't do right now as I'm travelling. I would also need to know what heading level is used for the 'Design Requirements' heading. A minor error in the posted code - change: With Content.Find to With .Content.Find
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#29
|
|||||
|
|||||
Hi Pual,
Thanks for your reply. Quote:
Paul, the pictures & figures are formatted “in-line’. I have managed to delete them as I found a code on the web which I included as ‘Call’ to your code. It works except it does not delete the numbers and captions. Code:
Sub DitchPictures(DocSrc) Dim objPic As InlineShape For Each objPic In ActiveDocument.InlineShapes objPic.Delete Next objPic End Sub Quote:
Quote:
The section that follow are not required. This 'Design Requirements' file is important. If this can be fixed the rest of the code is fine. Quote:
Paul, I keep on searching the web, I found this code from Microsoft.com, which separates all sections and creates individual pages (see code below). Will this code help to separate only 'Design Requirements' by modifying it. I don’t mind if this code is an exclusive and not added to your previous code. But, it should be the same as your code that creates a output folder and creates files. Code:
Sub BreakOnSection() ' Used to set criteria for moving through the document by section. Application.Browser.Target = wdBrowseSection 'A mail merge document ends with a section break next page. 'Subtracting one from the section count stop error message. For i = 1 To ((ActiveDocument.Sections.Count) - 1) 'Note: If a document does not end with a section break, 'substitute the following line of code for the one above: 'For I = 1 To ActiveDocument.Sections.Count 'Select and copy the section text to the clipboard. ActiveDocument.Bookmarks("\Section").Range.Copy 'Create a new document to paste text from clipboard. Documents.Add Selection.Paste ' Removes the break that is copied at the end of the section, if any. Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend Selection.Delete Unit:=wdCharacter, Count:=1 ChangeFileOpenDirectory "C:\" DocNum = DocNum + 1 ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc" ActiveDocument.Close ' Move the selection to the next section in the document. Application.Browser.Next Next i ActiveDocument.Close savechanges:=wdDoNotSaveChanges End Sub Quote:
I did try for an hour by playing around and entered this ‘With DocSrc.Content.Find’ it worked. Will this change anything in the code? Thanks once again FLDS |
#30
|
||||
|
||||
Hi flds,
Do the numbers & captions occur before, or after, the pictures? Are they part of the same paragraph, or are they separate paragraphs? Regarding the 'Design Requirements' portion of the document, when I refer to 'Section' I mean a Word Section defined via Section breaks - Word has no such thing as sub-sections. So, does the 'Design Requirements' portion of the document consist of one Section? The MS code is of no particular benefit; in fact, it is quite inefficient compared to what I've been using. The code I've provided already works on a Section basis. All I need to know is whether the 'Design Requirements' portion of the document consists of a single Section. Using 'With DocSrc.Content.Find' achieves the same thing as 'With .Content.Find' in this context, but is slightly less efficient.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
copy and paste not working | Ellie | Word | 3 | 11-07-2013 02:23 PM |
Can't copy paste | irenasobolewska | Office | 2 | 10-26-2012 05:09 PM |
Copy - Paste between 2 tables | rod147 | Excel | 1 | 10-22-2009 08:21 PM |
Copy & paste low resolution | worriedme | Drawing and Graphics | 0 | 06-01-2009 03:05 AM |
Copy and paste special | Dace | Excel | 2 | 02-16-2009 12:18 PM |