Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #16  
Old 06-22-2011, 03:43 AM
flds flds is offline Copy/Paste/Delete Table & Section etc. Windows XP Copy/Paste/Delete Table & Section etc. Office 2007
Novice
Copy/Paste/Delete Table & Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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
Reply With Quote
  #17  
Old 06-23-2011, 02:09 AM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table & Section etc. Windows 7 64bit Copy/Paste/Delete Table & Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Hi flds,
Quote:
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.
The code I posted already processes Appendices - provided they are formatted as described in my previous post. If you're not getting the results you expect, then you need to tell me how the Appendices can be distinguished from the rest of the document. As for References, what features uniquely distinguish the start of a Reference section from the rest of the document? Do they occur before, or after, Appendices?
Quote:
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.
I can't see how the merging of tables is possible using the code I posted - there should be an empty paragraph separating them. As for the margins, that's a necessary consequence of deleting the Section breaks. I could leave the Section breaks in the tables document, if you prefer. Do the titles appear before, or after, the tables? How are they identified (eg use of Word's Caption Style)?
Quote:
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.
That is inconsequential.
Quote:
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.
I can easily enough modify the code to handle that. Are there any other issues that need to be allowed for?
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #18  
Old 06-24-2011, 11:14 AM
flds flds is offline Copy/Paste/Delete Table & Section etc. Windows XP Copy/Paste/Delete Table & Section etc. Office 2007
Novice
Copy/Paste/Delete Table & Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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
Reply With Quote
  #19  
Old 06-26-2011, 05:16 PM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table & Section etc. Windows 7 64bit Copy/Paste/Delete Table & Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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
With the tables document, the modified code deletes as many Section breaks as possible without affecting the page orientation. Unless you've got mixed page sizes (eg A3 & A4) in the same document, that should go pretty close to meeting your needs. Any remaining Section breaks would have to be eyeballed to see if they can safely be deleted.

As for:
Quote:
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.
Well, yes, you can ask. But you'll need to say what those requirements are before I can do anything on that front.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #20  
Old 06-28-2011, 12:10 PM
flds flds is offline Copy/Paste/Delete Table &amp; Section etc. Windows XP Copy/Paste/Delete Table &amp; Section etc. Office 2007
Novice
Copy/Paste/Delete Table &amp; Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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.”
  • I need to output complete sections (incl. subsections) which heading contain the words “DESIGN REAUIREMENTS”
(ie. Headings may be anything like CONTROL DESIGN REQUIREMENTS or ?????? DESIGN REQUIREMENTS ??????) could be in upper or lower case.
  • I have a code which I found on the link below.
http://msdn.microsoft.com/en-us/library/bb960898.aspx (Tip #5)
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.
Reply With Quote
  #21  
Old 06-28-2011, 03:34 PM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table &amp; Section etc. Windows 7 64bit Copy/Paste/Delete Table &amp; Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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
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.

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]
Reply With Quote
  #22  
Old 06-29-2011, 05:51 AM
flds flds is offline Copy/Paste/Delete Table &amp; Section etc. Windows XP Copy/Paste/Delete Table &amp; Section etc. Office 2007
Novice
Copy/Paste/Delete Table &amp; Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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
Thanks
FLDS
Reply With Quote
  #23  
Old 06-29-2011, 04:41 PM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table &amp; Section etc. Windows 7 64bit Copy/Paste/Delete Table &amp; Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Hi flds,
Quote:
Appendix A, Appendix B, Appendix C etc. are separate in a line, following lines contain the text.
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).

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]
Reply With Quote
  #24  
Old 07-04-2011, 07:19 AM
flds flds is offline Copy/Paste/Delete Table &amp; Section etc. Windows XP Copy/Paste/Delete Table &amp; Section etc. Office 2007
Novice
Copy/Paste/Delete Table &amp; Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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
Reply With Quote
  #25  
Old 07-04-2011, 07:34 PM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table &amp; Section etc. Windows 7 64bit Copy/Paste/Delete Table &amp; Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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]
Reply With Quote
  #26  
Old 07-06-2011, 12:49 PM
flds flds is offline Copy/Paste/Delete Table &amp; Section etc. Windows XP Copy/Paste/Delete Table &amp; Section etc. Office 2007
Novice
Copy/Paste/Delete Table &amp; Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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.
Reply With Quote
  #27  
Old 07-07-2011, 05:54 AM
flds flds is offline Copy/Paste/Delete Table &amp; Section etc. Windows XP Copy/Paste/Delete Table &amp; Section etc. Office 2007
Novice
Copy/Paste/Delete Table &amp; Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

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
Reply With Quote
  #28  
Old 07-07-2011, 10:58 PM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table &amp; Section etc. Windows 7 64bit Copy/Paste/Delete Table &amp; Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Hi flds,
Quote:
Originally Posted by flds View Post
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.
Are the pictures formatted as 'in-line' or as 'square' etc? What are the 'figures' (eg are these graphics, captions for the pictures, something else)?
Quote:
Originally Posted by flds View Post
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.
Does the 'Design Requirements' portion of the document only ever comprise one Section? What do you want done with the 'Code and Standards' etc Sections that follow it?

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.
Quote:
Originally Posted by flds View Post
The macro halts at, and so I had to make it as a comment block.
A minor error in the posted code - change:
With Content.Find
to
With .Content.Find
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #29  
Old 07-08-2011, 08:22 AM
flds flds is offline Copy/Paste/Delete Table &amp; Section etc. Windows XP Copy/Paste/Delete Table &amp; Section etc. Office 2007
Novice
Copy/Paste/Delete Table &amp; Section etc.
 
Join Date: Apr 2011
Posts: 27
flds is on a distinguished road
Default

Hi Pual,

Thanks for your reply.

Quote:
“Are the pictures formatted as 'in-line' or as 'square' etc? What are the 'figures' (eg are these graphics, captions for the pictures, something else)?”

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:
“Does the 'Design Requirements' portion of the document only ever comprise one Section? What do you want done with the 'Code and Standards' etc Sections that follow it?”
Paul, Yes it comprise of one group of section with sub sections (i.e. 4. 'Design Requirements', 4.1. XXXXXXXX, 4.2. XXXXXXX, 4.2.1. XXXXXXX, 8. 8.1, 8.2, 8.2.1, etc.)

Quote:
“What do you want done with the 'Code and Standards' etc Sections that follow it?”
I need all sections that say 'Design Requirements' as one separate file.
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:
“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.”
Paul, Don’t bother, you can ignore this, I can live with the numbering.


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:
“A minor error in the posted code - change:
With Content.Find
to
With .Content.Find”
I will change to “With .Content.Find”
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
Reply With Quote
  #30  
Old 07-08-2011, 05:08 PM
macropod's Avatar
macropod macropod is offline Copy/Paste/Delete Table &amp; Section etc. Windows 7 64bit Copy/Paste/Delete Table &amp; Section etc. Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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]
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Copy/Paste/Delete Table &amp; Section etc. 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/Paste/Delete Table &amp; Section etc. Copy and paste special Dace Excel 2 02-16-2009 12:18 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:03 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft