Here is the text, originally courtesy of Gregory Maxey but customised
to my own purpose: Option Explicit
Private oUF2 As Advanced
Private AdvOption As Long
Private TextMark As String
Private Sub CheckBox2_Click()
If CheckBox2.Value = -1 Then
TextBox1.Enabled = True
Else
TextBox1.Enabled = False
End If
End Sub
Private Sub CheckBox4_Click()
If ActiveDocument.Tables.Count > 0 Then
Set oUF2 = New Advanced
Load oUF2
oUF2.Show vbModal
TextMark = oUF2.TextMark
AdvOption = CLng(oUF2.Frame1.Tag)
Unload oUF2
Set oUF2 = Nothing
End If
End Sub
Private Sub CheckBox8_Click()
'If System.PrivateProfileString("", _
' "HKEY_CURRENT_USER\Software\Microsoft\" _
' & "Office\11.0\Word\Options", "CleanUpText") <> "DoNotShow" Then
' Me.Hide
' Dim oUF2 As UserTip
' Set oUF2 = New UserTip
' Load oUF2
' oUF2.Show vbModal
' Unload oUF2
' Set oUF2 = Nothing
'End If
End Sub
Private Sub CommandButton1_Click()
Dim oRng As Word.Range
Dim bParaAdded As Boolean
Dim pWrap As Integer
Dim pStoryType As Integer
'TextMark = oUF2.TextMark
'AdvOption = CLng(oUF2.Frame1.Tag)
' Unload oUF2
' Set oUF2 = Nothing
Me.Hide
Word.Application.ScreenUpdating = False
If OptionButton1.Value = -1 Then
Set oRng = Selection.Range
'Ensure proper paragraph marks
pStoryType = oRng.StoryType
pWrap = 0
If oRng.Paragraphs.Count > 1 Then
ValidateParagraphs oRng, pWrap
If oRng.End = ActiveDocument.StoryRanges(pStoryType).End Then
oRng.Paragraphs.Last.Range.Delete
End If
End If
Set oRng = Nothing
If Selection.Range.Start =
ActiveDocument.StoryRanges(pStoryType).Start Then
Selection.InsertBefore Chr(13) bParaAdded = True
ElseIf Selection.Start <> Selection.Paragraphs(1).Range.Start Then
Selection.MoveStart Unit:=wdLine, Count:=-1
Selection.MoveStart Unit:=wdCharacter, Count:=-1
Else
Selection.MoveStart Unit:=wdCharacter, Count:=-1
End If
Set oRng = Selection.Range
pWrap = 0
'Call Processor
Process oRng, pWrap, bParaAdded, pStoryType
ElseIf OptionButton2.Value = -1 Then
Set oRng = Selection.Range
oRng.WholeStory
pStoryType = oRng.StoryType
pWrap = 1
'Ensure proper paragraph marks
If oRng.Paragraphs.Count > 1 Then
ValidateParagraphs oRng, pWrap
ActiveDocument.StoryRanges(pStoryType).Paragraphs.Last.Range.Delete
End If
ActiveDocument.StoryRanges(pStoryType).InsertBefore Chr(13)
pWrap = 1
bParaAdded = True
'Call Processor
Process oRng, pWrap, bParaAdded, pStoryType
Else
MakeHFValid
For Each oRng In ActiveDocument.StoryRanges
If oRng.StoryLength >= 2 Then 'Skips empty/near empty storyranges
pStoryType = oRng.StoryType
pWrap = 1
Do
'Ensure proper paragraph marks
If oRng.Paragraphs.Count > 1 Then
ValidateParagraphs oRng, pWrap
oRng.Paragraphs.Last.Range.Delete
End If
oRng.InsertBefore Chr(13)
pWrap = 1
bParaAdded = True
'Call Processor
Process oRng, pWrap, bParaAdded, pStoryType
Set oRng = oRng.NextStoryRange
Loop Until oRng Is Nothing
End If
Next
End If
'Me.Hide
Word.Application.ScreenRefresh
Word.Application.ScreenUpdating = True
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ": "
.Replacement.Text = ":"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
Private Sub CommandButton3_Click()
Me.Hide
Dim oUF1 As Tips
Set oUF1 = New Tips
Load oUF1
oUF1.Show vbModal
Unload oUF1
Set oUF1 = Nothing
End Sub
Private Sub UserForm_Initialize()
OptionButton3.Value = True
TextBox1.Enabled = False
CheckBox1.Value = True
CheckBox3.Value = True
CheckBox8.Value = True
CheckBox4.Value = True
CheckBox7.Value = True
End Sub
Private Sub Process(ByRef oRng As Range, ByVal pWrap As Integer, _
ByVal bParaAdded As Boolean, ByVal pStoryType As
Integer)
Dim TextCharArray As Variant
Dim i As Integer
Dim j As Integer
Dim EP As Range
Dim oPara As Paragraph
If CheckBox1.Value = -1 Then
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
For i = 1 To 8
Select Case i
Case 1
.Text = "(^13)( {1,})"
.Replacement.Text = "\1"
Case 2
.Text = "(^l)( {1,})"
.Replacement.Text = "\1"
Case 3
.Text = "( {1,})(^13)"
.Replacement.Text = "\2"
Case 4
.Text = "( {1,})(^l)"
.Replacement.Text = "\2"
Case 5
.Text = "(^13)(^s{1,})"
.Replacement.Text = "\1"
Case 6
.Text = "(^l)(^s{1,})"
.Replacement.Text = "\1"
Case 7
.Text = "(^s{1,})(^13)"
.Replacement.Text = "\2"
Case 8
.Text = "(^s{1,})(^l)"
.Replacement.Text = "\2"
Case Else
Exit For
End Select
.Execute Replace:=wdReplaceAll
Next
End With
End If
If CheckBox2.Value = -1 Then
TextCharArray = Split(TextBox1, "|")
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
For j = 0 To UBound(TextCharArray)
If InStr("*(){}[]!@?", TextCharArray(j)) > 0 Then
.MatchWildcards = True
.Text = "(^13)\" & TextCharArray(j) & "{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "\" & TextCharArray(j) & "{1,}(^13)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "(^l)\" & TextCharArray(j) & "{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "\" & TextCharArray(j) & "{1,}(^l)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
ElseIf InStr("<>", TextCharArray(j)) > 0 Then
.MatchWildcards = True
.Text = "(^13)[\" & TextCharArray(j) & "]{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "[\" & TextCharArray(j) & "]{1,}(^13)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "(^l)[\" & TextCharArray(j) & "]{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "[\" & TextCharArray(j) & "]{1,}(^l)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
Else
.MatchWildcards = True
.Text = "(^13)" & TextCharArray(j) & "{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = TextCharArray(j) & "{1,}(^13)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "(^l)" & TextCharArray(j) & "{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = TextCharArray(j) & "{1,}(^l)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
End If
Next j
End With
End If
If CheckBox1.Value = -1 Then
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
For i = 1 To 8
Select Case i
Case 1
.Text = "(^13)( {1,})"
.Replacement.Text = "\1"
Case 2
.Text = "(^l)( {1,})"
.Replacement.Text = "\1"
Case 3
.Text = "( {1,})(^13)"
.Replacement.Text = "\2"
Case 4
.Text = "( {1,})(^l)"
.Replacement.Text = "\2"
Case 5
.Text = "(^13)(^s{1,})"
.Replacement.Text = "\1"
Case 6
.Text = "(^l)(^s{1,})"
.Replacement.Text = "\1"
Case 7
.Text = "(^s{1,})(^13)"
.Replacement.Text = "\2"
Case 8
.Text = "(^s{1,})(^l)"
.Replacement.Text = "\2"
Case Else
Exit For
End Select
.Execute Replace:=wdReplaceAll
Next
End With
End If
'Replace line breaks with paragraph formatting
If CheckBox3.Value = -1 Then
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
For i = 1 To 2
Select Case i
Case 1
.Text = "^l{2,}"
.Replacement.Text = "^p"
Case 2
.Text = "^l{1,}"
.Replacement.Text = " "
Case Else
Exit For
End Select
.Execute Replace:=wdReplaceAll
Next
End With
End If
'Remove carriage returns at end of each line.
If CheckBox8.Value = -1 Then
With oRng.Find
.Text = "([!^13])(^13)([!^13])"
.Replacement.Text = "\1 \3"
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
With oRng.Find
.Text = "^13{2,}"
.Replacement.Text = "^p"
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End If
'Remove Empty Paragraphs
If CheckBox4.Value = -1 Then
With oRng.Find
.Text = "^13{2,}"
.Replacement.Text = "^p"
.Forward = True
.Wrap = pWrap
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
If AdvOption = 2 Then
For Each oPara In oRng.Paragraphs
If Len(oPara.Range.Text) = 1 Then
oPara.Range.Delete
End If
Next
Else
'Call Macro to process empty PMs in tables and nested tables
ProcessTables oRng, pStoryType
End If
If oRng.Paragraphs.Count > 1 Then
Set EP =
ActiveDocument.StoryRanges(pStoryType).Paragraphs.First.Range If
EP.Text = vbCr Then EP.Delete Set EP =
ActiveDocument.StoryRanges(pStoryType).Paragraphs.Last.Range If
EP.Text = vbCr Then EP.Delete End If
ElseIf bParaAdded = True Then
oRng.Paragraphs(1).Range.Delete
End If
'Clear Formatting
If CheckBox5.Value = -1 Then oRng.Font.Reset
If CheckBox6.Value = -1 Then oRng.ParagraphFormat.Reset
If CheckBox7.Value = -1 Then
oRng.Style = ActiveDocument.Styles(wdStyleNormal)
End If
If oRng.Paragraphs.Last.Range.Characters.Count = 1 Then
On Error Resume Next
oRng.Paragraphs.Last.Range.Delete
On Error GoTo 0
End If
Selection.Collapse Direction:=wdCollapseStart
End Sub
Private Sub ValidateParagraphs(ByVal oRng As Range, pWrap As Integer)
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = pWrap
.Text = "^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
End Sub
Private Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub ProcessTables(oRng As Range, pStoryType As Integer)
Dim TopTable As Table
Dim ttCell As Word.Cell
Dim Level As Long
Dim Level2Table As Word.Table
For Each TopTable In oRng.Tables
'Call Macro to process empty PMs between top level tables
BAITables TopTable, pStoryType
Level = 1
'Call Macro to process empty PMs in TopTable cells
ProcessCells TopTable, pStoryType
'Process TopTable for nested tables
For Each ttCell In TopTable.Range.Cells
If ttCell.Tables.Count > 0 Then
Dim j As Integer
For j = 1 To ttCell.Tables.Count
Set Level2Table = ttCell.Tables(j)
Level = 2
'Process cells in Level2 Tables
ProcessCells Level2Table, pStoryType
'Process deep nested Tables
ProcessNestedTable Level, Level2Table, TopTable, pStoryType
Next
End If
Next ttCell
Next
End Sub
Function ProcessNestedTable(NewLevel As Long, _
tbl As Word.Table, ByRef tblOuter As Word.Table, pStoryType As
Integer)
Dim celNested As Word.Cell
Dim tblNested As Word.Table
For Each celNested In tbl.Range.Cells
If celNested.Tables.Count > 0 Then
Set tblNested = celNested.Tables(1)
NewLevel = tblNested.NestingLevel
Set tblOuter = tblNested
ProcessCells tblNested, pStoryType
ProcessNestedTable NewLevel, tblNested, tblOuter, pStoryType
End If
Next celNested
End Function
Sub BAITables(oTbl As Table, pStoryType As Integer)
Dim myRange As Range
Dim emptyPara As Boolean
'Remove empty PMs immediate before, after, and between
'top level tables
Set myRange = oTbl.Range 'tbl.Range
myRange.Collapse wdCollapseEnd
If myRange.Paragraphs(1).Range.Text = vbCr Then
myRange.Collapse wdCollapseEnd
myRange.Move wdParagraph, 1
If myRange.Information(wdWithInTable) Then
'Do nothing. Issue will be resolve while
'processing next table.
Else
myRange.Move wdParagraph, -1
myRange.Paragraphs(1).Range.Delete
End If
End If
Set myRange = oTbl.Range
Do
myRange.Collapse wdCollapseStart
myRange.Move wdParagraph, -1
If myRange.Paragraphs(1).Range.Text = vbCr Then
myRange.Collapse wdCollapseStart
If myRange.Start = ActiveDocument.StoryRanges(pStoryType).Start
Then myRange.Paragraphs(1).Range.Delete
emptyPara = False
Else
myRange.Move wdParagraph, -1
If myRange.Information(wdWithInTable) Then
If AdvOption = 3 Then
myRange.Move wdParagraph, 1
emptyPara = True
myRange.Text = TextMark '"****"
End If
Else
myRange.Move wdParagraph, 1
emptyPara = True
myRange.Paragraphs(1).Range.Delete
End If
End If
Else
emptyPara = False
End If
Loop While emptyPara = True
End Sub
Sub ProcessCells(tbl As Table, ByVal pStoryType As Integer)
Dim oCell As Cell
Dim Counter As Integer
Dim oPara As Paragraph
Dim workingRng As Range
Dim prevTab As Range
Dim k As Integer
Dim emptyPara As Boolean
For Each oCell In tbl.Range.Cells
If oCell.Tables.Count > 1 Then
'Process PMs before first table
Set workingRng = oCell.Tables(1).Range
Do
workingRng.Collapse wdCollapseStart
workingRng.Move wdParagraph, -1
If workingRng.Paragraphs(1).Range.Text = vbCr Then
workingRng.Paragraphs(1).Range.Delete
emptyPara = True
Else
emptyPara = False
End If
Loop While emptyPara = True
For k = 2 To oCell.Tables.Count
Set workingRng = oCell.Tables(k).Range
'Process PM after last table
If k = oCell.Tables.Count Then
workingRng.Collapse wdCollapseEnd
If workingRng.Paragraphs(1).Range.Text = vbCr Then
workingRng.Paragraphs(1).Range.Delete
End If
Set workingRng = oCell.Tables(k).Range
End If
'Process PMs preceeding remaining tables
Set prevTab = oCell.Tables(k - 1).Range
workingRng.Select
Do
workingRng.Collapse wdCollapseStart
workingRng.Move wdParagraph, -1
If workingRng.Paragraphs(1).Range.Text = vbCr Then
workingRng.Collapse wdCollapseStart
workingRng.Move wdParagraph, -1
If workingRng.InRange(prevTab) Then
If AdvOption = 3 Then
workingRng.Move wdParagraph, 1
emptyPara = True
workingRng.Text = TextMark '"****"
End If
Else
workingRng.Move wdParagraph, 1
emptyPara = True
workingRng.Paragraphs(1).Range.Delete
End If
Else
emptyPara = False
End If
Loop While emptyPara = True
Next
Else
For Each oPara In oCell.Range.Paragraphs
If oPara.Range.Characters(1).Text = vbCr Then
oPara.Range.Delete
End If
Next
If Len(oCell.Range.Text) > 2 And _
Asc(Right$(oCell.Range.Text, 3)) = 13 Then
oCell.Range.Characters(Len(oCell.Range.Text) - 2).Delete
End If
End If
Next
End Sub
Graham Mayor said:
Paste all the code and we might have a better idea what the problem
is.
--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
