Need macro to split large word doc by headings - Page 2
Attribute VB_Name = "SPLIT_BY_HEADINGS"
Option Explicit
Const levels = 2 ''Levels to consider in parsing
Dim level() As Integer ''Level counter- reset lower levels at each turn of a higher level
Sub SplitByPara()
Dim I As Integer ''counter variable
Dim Para As Paragraph ''loop para
Dim ParaLast As Paragraph ''last paragraph the caught flac
Dim paraPriev As Paragraph ''paragraph from previous loop
Dim aDoc As Document ''active document
Dim FP As String ''File Path
Set aDoc = ActiveDocument ''abbreviated active document
FP = aDoc.Path & "\" & StrFormat(aDoc.Name)
NewFolder FP ''Call to new folder- open folder or bring focus to front
ReDim level(1 To levels)
Set ParaLast = aDoc.Paragraphs.First ''prime paragraphs for loop
Set paraPriev = aDoc.Paragraphs.First ''prime paragraphs for loop
'''Iterate through paragraphs in current document'''
For I = 2 To aDoc.Paragraphs.Count ''paras from next-to-last to first
Set Para = aDoc.Paragraphs(I)
'If aDoc.Paragraphs.Count = 1 Or _
' (Parastyles(Para, Array("Heading 1*", "Heading 2*", "*Appendix*")) _
' And Para.Range.Text > "") _
' Then
If (Parastyles(Para, Array("Heading 1*", "Heading 2*", "*Appendix*")) _
And Para.Range.Text > "") _
Then
'''copy form para2 to para
ParasWriteOut FP, I, ParaLast, paraPriev
Set ParaLast = Para ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set ref to last flag point
End If
Set paraPriev = Para ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Set previous paragraph
Next I
ParasWriteOut FP, I, ParaLast, paraPriev '''''''''''''''''''''''''''''''''''''''''''''writeout last para
End Sub
Sub ParasWriteOut(FP As String, I As Integer, Parastart As Paragraph, ParaEnd As Paragraph)
Dim fn As String ''File name
Dim bDoc As Document ''writeout document per piece
Dim rng As Range ''Range to write out
Dim x
Dim J As Integer
fn = format(I, "0000") & "-"
If Not Parastart.Range.ListFormat.List Is Nothing Then ''use numbers from list to write out
x = Split(PadParanums(Parastart.Range.ListFormat.ListString, 2), "-")
For J = 1 To levels
level(J) = Val(x(J - 1))
Next J
ElseIf Parastart.OutlineLevel <= levels Then ''use level formatting
level(Parastart.OutlineLevel) = level(Parastart.OutlineLevel) + 1 ''increment levels
''fn = fn & PadParanums(Parastart.OutlineLevel, levels) & "-"
End If
For J = Parastart.OutlineLevel + 1 To levels
level(J) = 0 ''reset levels
Next J
fn = fn & PadParanums(level(1) & "-" & level(2), levels) & "-"
fn = Left(Trim(fn & Parastart.Range.Text), 64)
fn = StrFormat(fn)
Set rng = ActiveDocument.Range(Parastart.Range.Start, ParaEnd.Range.End)
Set bDoc = Documents.Add(Visible:=False)
bDoc.Content.FormattedText = rng
'''reset colors to automatic
bDoc.Content.Font.Color = wdColorAutomatic
On Error Resume Next
VBA.Kill FP & fn
bDoc.SaveAs FP & fn, fileformat:=Word.wdFormatDocument, addtorecentfiles:=False, allowsubstitutions:=False
''allow substitutions allows word to substitutie characters with similar looking characters (ie © with (C))
On Error GoTo 0
bDoc.Close False
Set bDoc = Nothing
End Sub
Private Function PadParanums(strString As String, Optional levels As Integer) As String '' add 0's in numbered formats
Dim x
Dim I, xI
strString = StrFormat(strString)
x = Split(strString, "-")
Const format = "000"
xI = -1
On Error Resume Next
xI = UBound(x)
On Error GoTo 0
For I = 0 To xI
If x(I) Like "*#*" Then
PadParanums = PadParanums & Right(format & x(I), 3) & "-"
End If
Next I
For I = UBound(Split(PadParanums, "-")) To levels - 1 ''use padparanums to determine number of levels defined then add padded 000- for remining
PadParanums = PadParanums & format & "-"
Next I
PadParanums = StrFormat(PadParanums)
End Function
Private Function Parastyles(Para As Paragraph, strStyles) As Boolean
Dim I As Integer
Dim K As Integer
I = -1
On Error Resume Next
I = UBound(strStyles)
On Error GoTo 0
For K = 0 To I
If Para.Style Like strStyles(K) Then
Parastyles = True
Exit Function
End If
Next K
End Function
Function StrFormat(strString As String) As String
Dim regex As New regexp
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[^a-zA-Z0-9\-]"
End With
StrFormat = regex.Replace(strString, "-")
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\-{1,}"
End With
StrFormat = regex.Replace(StrFormat, "-")
'''Remove trailing dashes
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\-{1,}(?=\s|$)"
End With
StrFormat = regex.Replace(StrFormat, "")
End Function
Sub NewFolder(FP As String, Optional DoNotOpen As Boolean)
Dim OpenFold As Variant
Dim oShell As Object
Dim Wnd As Object
''Dim strFolder
''OpenFold = "mysubfolder"
''strFolder = "U:\myfolder\" & OpenFold
Set oShell = CreateObject("Shell.Application")
''Wnd.LocationName
''Cread subfolder for paragraphs
On Error Resume Next
VBA.MkDir (FP)
FP = FP & "\"
On Error GoTo 0
For Each Wnd In oShell.Windows
Debug.Print Wnd.Document.Folder.Self.Path
'' If Wnd.LocationName = "Windows Explorer" Then
If LCase(Wnd.Document.Folder.Self.Path & "\") = LCase(FP) Then
Wnd.Visible = True
Exit Sub
End If
''End If
Next Wnd
If Not DoNotOpen Then Shell "C:\WINDOWS\explorer.exe """ & FP & "", vbNormalFocus
End Sub
Comments
Post a Comment