Dayo said:
Mark, I would be interested in seeing your macro to synchronize page numbers
across files, just to stash away in case I need it one day. Would also not
mind seeing your proper de/capitalization macro, if you don't mind.
Here they are. The capping/decapping macro follows first.
Note that the code structure is pretty messy since this was
built in a big hurry and adjusted many times, also usually
in a big hurry. And there's some stuff n it (state/federal)
related to my job that I don't have time to excise just now.
Also, no time to trim the linebreaks, so I assume you know
what to do with lines that wrap here. The NotForCapping
function that follows it and is required.
The repaging macro is the last one shown below. It's brand
new (and looks it), so while I don't think it has serious bugs,
it's probably got a lot of sloppy code. One thing it *doesn't*
handle is documents whose page numbering sequence changes in
the middle.
--
Mark Tangard, Microsoft Word MVP
Please reply only to the newsgroup, not by private email.
Note well: MVPs do not work for Microsoft.
"Life is nothing if you're not obsessed." --John Waters
Sub CapperDecapper()
If Documents.Count = 0 Then Exit Sub
Dim r As String, ra As Range, w As Range, tmp As String
ActiveWindow.ActivePane.View.ShowAll = False
If Selection.End - Selection.Start = 0 Then
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
RepeatMe:
r = Selection.Text
Select Case r
Case "A" To "Z"
tmp = Selection.Text
Selection.Delete
Selection.InsertBefore LCase(tmp)
Case "a" To "z"
If NotForCapping() = False Then
tmp = Selection.Text
Selection.Delete
Selection.InsertBefore UCase(tmp)
End If
Case "."
Selection.Range.Text = "."
Case ","
Selection.Range.Text = ","
Case " "
Selection.Collapse wdCollapseEnd
Selection.MoveRight wdCharacter, 1, wdExtend
GoTo RepeatMe
End Select
Else
Set ra = Selection.Characters(1)
Select Case ra.Text
Case "A" To "Z"
ra.Case = wdLowerCase
Set w = Selection.Words(1)
If w.Characters.Last = " " Then w.MoveEnd
wdCharacter, -1
If UCase(w.Text) = "STATE" Or UCase(w.Text) =
"FEDERAL" Then w.HighlightColorIndex = wdNoHighlight
Case "."
ra.Text = "."
Case ","
ra.Text = ","
Case Else
ra.Case = wdUpperCase
Set w = Selection.Words(1)
If w.Characters.Last = " " Then w.MoveEnd
wdCharacter, -1
If UCase(w.Text) = "STATE" Or UCase(w.Text) =
"FEDERAL" Then w.HighlightColorIndex = wdNoHighlight
End Select
End If
Selection.MoveRight Unit:=wdWord, Count:=1
CheckNext:
r = Selection.Words(1).Characters(1).Text
Select Case r
Case "a" To "z", "A" To "Z", "", Chr$(13)
Exit Sub
Case Else
Selection.MoveRight Unit:=wdWord, Count:=1
GoTo CheckNext
End Select
End Sub
=============
Function NotForCapping() As Boolean
NotForCapping = False
Dim r As Range
If Selection.Characters.first = ActiveDocument.Characters.first Then Exit
Function
If Selection.Characters.first.Previous <> " " Then Exit Function
Select Case Trim(Selection.Words(1).Text)
Case "a", "an", "and", "the", "as", "at", "by", "for", "from", "in", "into",
"of", "on", "onto", "or", "out", "to", "up" ', "with", "within", "without"
Set r = Selection.Words(1)
r.Collapse wdCollapseStart
r.MoveStart wdCharacter, -3
If InStr(r.Text, ". ") <> 0 Then Exit Function
NotForCapping = True
End Select
End Function
=============
Sub RepaginateSequentialClumpOfFiles()
Dim strStartPg As String, StartPg As Long, fol As String, i As Long, d As
Document, VeryLastPg As Long, PrevVeryLastPg As Long, r As Range, PrevDocEndPg
As Long, InitialPageList As String, FileList As String
fol = Trim(InputBox("Folder name?"))
If fol = "" Then Exit Sub
AskPg:
strStartPg = InputBox("ENTER THE STARTING PAGE NUMBER:", , "1")
strStartPg = Trim(strStartPg)
If strStartPg = "" Then Exit Sub
If Not IsNumeric(strStartPg) Then
If MsgBox("Must be a *number*, Melvin.", vbOKCancel, " Uncool Page Number
Detected.") = vbCancel Then Exit Sub
GoTo AskPg
End If
StartPg = Val(strStartPg)
With Application.FileSearch
.NewSearch
.LookIn = fol
.SearchSubFolders = False
.FileName = "*.DOC"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
FileList = FileList & vbCr & " " & Mid$(.FoundFiles(i),
InStrRev(.FoundFiles(i), "\") + 1, 99)
Next i
Else
MsgBox "No matching files found."
Exit Sub
End If
If MsgBox("Files to be processed (" & .FoundFiles.Count & "):" & vbCr &
FileList & vbCr & vbCr & "Continue?", vbOKCancel, " Ready to Process Files") =
vbCancel Then Exit Sub
End With
With Application.FileSearch
.NewSearch
.LookIn = fol
.SearchSubFolders = False
.FileName = "*.DOC"
.Execute
For i = 1 To .FoundFiles.Count
Set d = Documents.Open(FileName:=.FoundFiles(i))
d.Activate
If i = .FoundFiles.Count Then
Set r = d.Range
r.Collapse wdCollapseEnd
PrevVeryLastPg = r.Information(wdActiveEndAdjustedPageNumber)
End If
Set r = d.Range
r.Collapse wdCollapseStart
Selection.Sections(1).Headers(1).PageNumbers.RestartNumberingAtSection =
True
If i = 1 Then
Selection.Sections(1).Headers(1).PageNumbers.StartingNumber =
StartPg
InitialPageList = Trim(Str(StartPg))
Else
Selection.Sections(1).Headers(1).PageNumbers.StartingNumber =
PrevDocEndPg + 1
InitialPageList = InitialPageList & " " & Trim(Str(PrevDocEndPg +
1))
End If
d.Repaginate
DoEvents
If i = 1 Then
PrevDocEndPg = StartPg + d.ComputeStatistics(wdStatisticPages) - 1
Else
PrevDocEndPg = PrevDocEndPg + d.ComputeStatistics(wdStatisticPages)
End If
If i = .FoundFiles.Count Then VeryLastPg = PrevDocEndPg
d.Close -1
Next i
MsgBox "Finished." & vbCr & vbCr & "New last page = " & PrevDocEndPg & vbCr
& "Was previously = " & PrevVeryLastPg & vbCr & vbCr & "Initial pages = " &
InitialPageList, , " Repagination - Summary"
End With
End Sub
