thdltools/VBAProjects
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity
VBAProjects/WordToXML/NewMacros.bas

1090 lines
35 KiB
QBasic
Raw Normal View History

Initial revision
2004-08-11 21:14:35 +00:00
Attribute VB_Name = "NewMacros"
Sub conversionHelp()
Dim msgTitle, msg As String
msgTitle = "Conversion Macro Help"
msg = "The shortcut keys for the conversion macros are as follows:" & vbCrLf & _
vbTab & "Convert Document to XML:" & vbTab & " Ctrl + Alt + c" & vbCrLf & _
vbTab & "Convert Italics to Specific Styles: Alt + i" & vbCrLf & _
vbTab & "Display This Help Message: " & vbTab & " Alt + Shift + ?"
res = MsgBox(msg, vbOKOnly, msgTitle)
End Sub
Sub convertToXML()
Dim teiHead, flName, temp, writepath As String
Dim rng As Range
ActiveDocument.Endnotes.Convert
writepath = ThisDocument.Path
' Replace entities
Application.StatusBar = "Proceessing document: replacing entities!"
replaceEntities
' Do Metadata
Application.StatusBar = "Proceessing document: converting metadata!"
teiHead = doMetadata
' Deal with italicized commas
Application.StatusBar = "Proceessing document: de-italicizing commas!"
unItalicizeCommas
'Deal with tables
Application.StatusBar = "Processing document: processing tables!"
doTables
' Do specific character styles
Application.StatusBar = "Proceessing document: processing character styles!"
doCharacterStyles
' Do the Links
Application.StatusBar = "Proceessing document: processing links!"
doLinks
' Do FootNotes
Application.StatusBar = "Proceessing document: processing foot- or endnotes!"
doFootNotes
doNoteTags
' Do the Italics Bold and Underline
Application.StatusBar = "Proceessing document: marking bold, italic, and underline!"
doItalicsBoldUnderline
' Do the Paragraph tags
doParas
' Do the Divs
Application.StatusBar = "Proceessing document: marking outline divisions!"
doDivs
' Clean up
replaceAllEmptyP
Application.StatusBar = "Proceessing document: finalizing markup!"
Selection.HomeKey unit:=wdStory
Selection.TypeParagraph
Selection.MoveUp unit:=wdLine, Count:=1
Selection.Style = "Normal,no"
Selection.TypeText Text:=teiHead
Selection.EndKey unit:=wdStory
Selection.TypeText Text:="</body></text></TEI.2>"
Selection.EndKey unit:=wdStory, Extend:=wdExtend
Selection.Cut
Selection.HomeKey unit:=wdStory
MsgBox ("Conversion complete! Copy the results and paste into your XML editor!")
Exit Sub
End Sub
Sub doDivs()
Dim tagName, closeTag, lastTag, headNum, styleName As String
Dim cnt, ind1, ind2, lvl, lastLvl, numOfLevels As Integer
numOfLevels = findHighestHeader()
ActiveWindow.ActivePane.View.Type = wdMasterView
ActiveWindow.View.ShowHeading 9
cnt = ActiveWindow.ActivePane.Document.Paragraphs.Count - 1
With Selection
.HomeKey unit:=wdStory
lastLvl = 0
For n = 1 To cnt
styleName = .Style
If InStr(styleName, "Head") > 0 Then
ind1 = InStr(styleName, " ") + 1
ind2 = InStr(styleName, ",") - ind1
headNum = Mid(styleName, ind1, ind2)
lvl = Val(headNum)
If numOfLevels < 8 Then
tagName = "div" & headNum
closeTag = tagName
Else:
tagName = "div n=""" & lvl & """"
closeTag = "div"
End If
If lastLvl = lvl Then
.TypeText ("</" & closeTag & ">")
ElseIf lastLvl > lvl Then
For lvNum = lastLvl To lvl Step -1
If numOfLevels < 8 Then
.TypeText ("</div" & lvNum & ">")
Else:
.TypeText ("</div>")
End If
Next lvNum
End If
lastLvl = lvl
.TypeText ("<" & tagName & "><head>")
If n < cnt Then
.MoveDown unit:=wdParagraph, Count:=1
.MoveLeft unit:=wdCharacter, Count:=1
Else
.EndKey unit:=wdStory
End If
.TypeText ("</head>")
End If
.MoveDown unit:=wdParagraph, Count:=1
Next n
ActiveWindow.ActivePane.View.Type = wdNormalView
.EndKey unit:=wdStory
For n = lvl To 1 Step -1
If numOfLevels < 8 Then
.TypeText ("</div" & n & ">")
Else
.TypeText ("</div>")
End If
Next n
End With
End Sub
Function findHighestHeader() As Integer
Dim para As Paragraph
Dim lvl, highest As Integer
highest = 1
For Each para In ActiveDocument.Paragraphs
styleName = para.Style
If InStr(styleName, "Head") > 0 Then
ind1 = InStr(styleName, " ") + 1
ind2 = InStr(styleName, ",") - ind1
headNum = Mid(styleName, ind1, ind2)
lvl = Val(headNum)
If lvl > highest Then highest = lvl
End If
Next para
findHighestHeader = highest
End Function
Sub doParas()
Dim inList, inVerse As Boolean
Dim rng As Range
Dim openTag, endTag, tagName As String
Dim ct As Integer
inList = False: inVerse = False
Selection.HomeKey unit:=wdStory
ct = ActiveDocument.Paragraphs.Count
For n = 1 To ct
Set para = ActiveDocument.Paragraphs(n)
Application.StatusBar = "Proceessing document: marking paragraphs (" & n & ")!"
If InStr(para.Style, "Heading") > 0 Then GoTo 50
If isTable(para) Then GoTo 50
tagName = "": openTag = "": endTag = ""
Select Case para.Style
Case "List Number,ln"
If inVerse Then
inVerse = False
openTag = "</lg>"
End If
If Not inList Then
openTag = openTag & "<list rend=""1"">"
inList = True
End If
tagName = "item"
Case "List Bullet,lb"
If inVerse Then
inVerse = False
openTag = "</lg>"
End If
If Not inList Then
openTag = openTag & "<list rend=""bullet"">"
inList = True
End If
tagName = "item"
Case "Citation Prose,cp"
If inList Then
openTag = "</list>"
inList = False
End If
If inVerse Then
inVerse = False
openTag = "</lg>"
End If
tagName = "q"
Case "Citation Verse 1,cv1"
If inList Then
openTag = "</list>"
inList = False
End If
If Not inVerse Then
openTag = openTag & "<lg>"
inVerse = True
End If
tagName = "l"
Case "Citation Verse 2,cv2"
If inList Then
openTag = "</list>"
inList = False
End If
If Not inVerse Then
openTag = openTag & "<lg>"
inVerse = True
End If
tagName = "l"
Case Else
If inList Then
openTag = "</list>"
inList = False
ElseIf inVerse Then
openTag = "</lg>"
inVerse = False
End If
tagName = "p"
End Select
Set rng = ActiveDocument.Paragraphs(n).Range
rng.StartOf
rng.Text = openTag & "<" & tagName & ">"
Set rng = ActiveDocument.Paragraphs(n).Range
rng.End = rng.End - 1
rng.EndOf
rng.Text = "</" & tagName & ">" & endTag
ActiveDocument.Paragraphs(n).Style = "Normal,no"
50 Next n
End Sub
Function isTable(ByVal para As Paragraph) As Boolean
Dim tct, pst, pend, tst, tend As Integer
pst = para.Range.Start
pend = para.Range.End
tct = ActiveDocument.Tables.Count
For n = 1 To tct
With ActiveDocument.Tables(n)
tst = .Range.Start
tend = .Range.End
End With
If pst >= tst And pst <= tend Then
isTable = True
Exit Function
End If
If pend >= tst And pend <= tend Then
isTable = True
Exit Function
End If
Next n
isTable = False
End Function
Sub doTables()
Dim tble As Table
Dim wrkCell As Cell
Dim outStr As String
Dim rwInd As Integer
Dim insertRng As Range
While ActiveDocument.Tables.Count > 0
outStr = "<list rend=""table""><item>"
Set tble = ActiveDocument.Tables.Item(1)
Set wrkCell = tble.Cell(1, 1)
rwInd = 1
While Not (wrkCell Is Nothing)
If wrkCell.Row.Index > rwInd Then
outStr = outStr & "</item><item>"
End If
rwInd = wrkCell.RowIndex
outStr = outStr & addToTable(wrkCell)
Set wrkCell = wrkCell.Next
Wend
outStr = outStr & "</item></list>"
Set insertRng = tble.Range
insertRng.Collapse wdCollapseStart
tble.Delete
insertRng.Select
Selection.TypeText Text:=outStr
Wend
End Sub
Function addToTable(ByVal cl As Cell) As String
Dim rng As Range
Set rng = cl.Range
rng.End = rng.End - 1
addToTable = "<rs>" & rng.Text & "</rs>"
End Function
Sub doFootNotes()
Attribute doFootNotes.VB_Description = "Macro recorded 8/12/2003 by Than G"
Attribute doFootNotes.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.FootnoteTest"
'
' FootnoteTest Macro
' Macro recorded 8/12/2003 by Than G
'
Dim fn As Footnote
Dim n, fnNum As Integer
Dim rng As Range
ActiveDocument.Endnotes.Convert
fnNum = ActiveDocument.Footnotes.Count
If fnNum > 0 Then
For n = 1 To fnNum
doFootnoteItalEtc (n)
Set fn = ActiveDocument.Footnotes.Item(n)
fn.Range.Select
Selection.Text = Replace(Selection.Text, Chr(13), "<!--[newLine]-->")
Selection.Copy
ActiveWindow.ActivePane.Close
With Selection
.GoTo what:=wdGoToFootnote, Which:=wdGoToFirst, Count:=n, Name:=""
.TypeText Text:="~"
.Paste
.TypeText Text:="^"
.MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
End With
Next n
n = 1
Do
ActiveDocument.Footnotes.Item(1).Delete
n = n + 1
If n > fnNum Then Exit Do
Loop While ActiveDocument.Footnotes.Count > 0
End If
End Sub
Sub doLinks()
Dim hyl As Hyperlink
Dim n, hyNum As Integer
Dim rng As Range
Dim addr As String
hyNum = ActiveDocument.Hyperlinks.Count
For n = 1 To hyNum
Set hyl = ActiveDocument.Hyperlinks.Item(n)
addr = hyl.Address
Set rng = hyl.Range
With rng.Font
.Italic = False
.Bold = False
.Underline = wdUnderlineNone
End With
rng.StartOf
rng.Text = "<xref n=""" & addr & """>"
Set rng = hyl.Range
rng.End = rng.End - 1
rng.EndOf
rng.Text = "</xref>"
Next n
End Sub
Sub doItalicsBoldUnderline()
Dim rngToSearch, srchResult, wrng As Range
Dim fcount, addOn, y, max As Integer
Dim doingFeet As Boolean
' Do the body of the text now
Set rngToSearch = ActiveDocument.Range
Set srchResult = rngToSearch.Duplicate
max = 100
' Search and Replace ITALICS
y = 0
Do
y = y + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
Set wrng = srchResult.Duplicate
addOn = 1
If wrng.Style = "Normal,no" Or InStr(wrng.Style, "List") > 0 Then
If Not isCharStyle(wrng) Then
Set wrng = fixRange(wrng)
wrng.Font.Italic = False
wrng.StartOf
wrng.Text = "<hi rend=""weak"">"
Set wrng = srchResult.Duplicate
wrng.End = wrng.End - 1
wrng.EndOf
wrng.Text = "</hi>"
wrng.Font.Italic = False
addOn = 5
End If
End If
srchResult.Start = wrng.End + addOn
srchResult.End = rngToSearch.End
If y > 100 Then Exit Do
Loop Until Not srchResult.Find.Found
' Search and Replace BOLD
y = 0
Set srchResult = rngToSearch.Duplicate
Do
y = y + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Bold = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
Set wrng = srchResult.Duplicate
addOn = 1
If wrng.Style = "Normal,no" Or InStr(wrng.Style, "List") > 0 Then
If Not isCharStyle(wrng) Then
Set wrng = fixRange(wrng)
wrng.Font.Bold = False
wrng.StartOf
wrng.Text = "<hi rend=""strong"">"
Set wrng = srchResult.Duplicate
wrng.End = wrng.End - 1
wrng.EndOf
wrng.Text = "</hi>"
wrng.Font.Bold = False
addOn = 5
End If
End If
srchResult.Start = wrng.End + addOn
srchResult.End = rngToSearch.End
If y > 100 Then Exit Do
Loop Until Not srchResult.Find.Found
' Do Underline
y = 0
Set srchResult = rngToSearch.Duplicate
Do
y = y + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Underline = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
Set wrng = srchResult.Duplicate
addOn = 1
If wrng.Style = "Normal,no" Or InStr(wrng.Style, "List") > 0 Then
If Not isCharStyle(wrng) Then
Set wrng = fixRange(wrng)
wrng.Font.Underline = wdUnderlineNone
wrng.StartOf
wrng.Text = "<hi rend=""underline"">"
Set wrng = srchResult.Duplicate
wrng.End = wrng.End - 1
wrng.EndOf
wrng.Text = "</hi>"
wrng.Font.Underline = wdUnderlineNone
addOn = 5
End If
End If
srchResult.Start = wrng.End + addOn
srchResult.End = rngToSearch.End
If y > 100 Then Exit Do
Loop Until Not srchResult.Find.Found
End Sub
Function doMetadata() As String
Attribute doMetadata.VB_Description = "Macro recorded 8/13/2003 by Than G"
Attribute doMetadata.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.tableaccess"
'
' tableaccess Macro
' Macro recorded 8/13/2003 by Than G
'
Dim metaTable As Table
Dim inData, header As String
Open "C:\xml\teiHeader.dat" For Input As #1
Do While Not EOF(1)
Line Input #1, inData
header = header & inData & vbCrLf
Loop
Close #1
Set metaTable = ActiveDocument.Tables(1)
header = Replace(header, "{Eng Lang}", doTrim(metaTable.Cell(3, 2)))
header = Replace(header, "{Eng Title}", doTrim(metaTable.Cell(1, 2)))
header = Replace(header, "{Orig Lang}", doTrim(metaTable.Cell(3, 4)))
header = Replace(header, "{Orig Title}", doTrim(metaTable.Cell(2, 2)))
header = Replace(header, "{Author}", doTrim(metaTable.Cell(4, 2)))
header = Replace(header, "{Author Date}", doTrim(metaTable.Cell(4, 4)))
header = Replace(header, "{Trans}", doTrim(metaTable.Cell(5, 2)))
header = Replace(header, "{Trans Date}", doTrim(metaTable.Cell(5, 4)))
header = Replace(header, "{Editor}", doTrim(metaTable.Cell(6, 2)))
header = Replace(header, "{Editor Date}", doTrim(metaTable.Cell(6, 4)))
header = Replace(header, "{Markup}", doTrim(metaTable.Cell(7, 2)))
header = Replace(header, "{Markup Date}", doTrim(metaTable.Cell(7, 4)))
header = Replace(header, "{Journal Title}", doTrim(metaTable.Cell(3, 2)))
header = Replace(header, "{Editor Coll}", doTrim(metaTable.Cell(9, 2)))
header = Replace(header, "{Vol}", doTrim(metaTable.Cell(8, 4)))
header = Replace(header, "{Pages}", doTrim(metaTable.Cell(8, 6)))
header = Replace(header, "{Pub Place}", doTrim(metaTable.Cell(11, 2)))
header = Replace(header, "{Pub Per}", doTrim(metaTable.Cell(10, 2)))
header = Replace(header, "{Pub Date}", doTrim(metaTable.Cell(10, 4)))
header = Replace(header, "{Description}", doTrim(metaTable.Cell(12, 2)))
header = Replace(header, "{Domain URL}", doTrim(metaTable.Cell(13, 2)))
header = Replace(header, "{Domain Text}", doTrim(metaTable.Cell(13, 4)))
header = Replace(header, "{Portal URL}", doTrim(metaTable.Cell(14, 2)))
header = Replace(header, "{Portal Text}", doTrim(metaTable.Cell(14, 4)))
header = Replace(header, "{Project URL}", doTrim(metaTable.Cell(15, 2)))
header = Replace(header, "{Project Text}", doTrim(metaTable.Cell(15, 4)))
header = Replace(header, "{Home URL}", doTrim(metaTable.Cell(16, 2)))
header = Replace(header, "{Home Text}", doTrim(metaTable.Cell(16, 4)))
ActiveDocument.Tables(1).Delete
doMetadata = header
End Function
Function doTrim(ByVal aCell As Cell) As String
Dim rng As Range
Set rng = aCell.Range
rng.End = rng.End - 1
doTrim = rng.Text
End Function
Function fixRange(ByVal rng As Range) As Range
Dim gtPlace, ltPlace As Integer
rng.Select
rng.Style = "Plain Text"
rng.Font.Bold = False
rng.Font.Italic = False
rng.Font.Underline = wdUnderlineNone
gtPlace = InStr(rng.Text, ">")
ltPlace = InStr(rng.Text, "<")
If gtPlace < ltPlace Then
If gtPlace > 0 Then rng.Start = rng.Start + gtPlace
If ltPlace > 0 Then rng.End = rng.Start + ltPlace - 1
ElseIf gtPlace > ltPlace Then
rng.End = rng.Start + ltPlace - 1
End If
Set fixRange = rng
End Function
Sub doNoteTags()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "~"
.Replacement.Text = "<note>"
.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 = "</note>"
.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
Sub doFootnoteItalEtc(ByVal fn As Integer)
Attribute doFootnoteItalEtc.VB_Description = "Macro recorded 8/13/2003 by Than G"
Attribute doFootnoteItalEtc.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.closeFootnotes"
'
' closeFootnotes Macro
' Macro recorded 8/13/2003 by Than G
'
'ActiveDocument.Endnotes.Convert
Dim loopCt, addOn As Integer
loopCt = 0
Set rngToSearch = ActiveDocument.Footnotes.Item(fn).Range
rngToSearch.End = rngToSearch.End - 1
Set srchResult = rngToSearch.Duplicate
Do
loopCt = loopCt + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
addOn = 2
Set wrng = srchResult.Duplicate
If Not isCharStyle(wrng) Then
wrng.StartOf
wrng.Text = "<hi rend=""weak"">"
Set wrng = srchResult.Duplicate
wrng.End = wrng.End - 1
wrng.EndOf
wrng.Text = "</hi>"
addOn = 5
End If
srchResult.Start = wrng.End + addOn
srchResult.End = rngToSearch.End
If loopCt > 10 Then Exit Do
Loop Until Not srchResult.Find.Found
loopCt = 0
Set srchResult = rngToSearch.Duplicate
Do
loopCt = loopCt + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Bold = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
Set wrng = srchResult.Duplicate
addOn = 2
If Not isCharStyle(wrng) Then
wrng.StartOf
wrng.Text = "<hi rend=""strong"">"
Set wrng = srchResult.Duplicate
wrng.End = wrng.End - 1
wrng.EndOf
wrng.Text = "</hi>"
addOn = 5
End If
srchResult.Start = wrng.End + addOn
srchResult.End = rngToSearch.End
If loopCt > 10 Then Exit Do
Loop Until Not srchResult.Find.Found
loopCt = 0
Set srchResult = rngToSearch.Duplicate
Do
loopCt = loopCt + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Underline = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
Set wrng = srchResult.Duplicate
addOn = 2
If Not isCharStyle(wrng) Then
wrng.StartOf
wrng.Text = "<hi rend=""underline"">"
Set wrng = srchResult.Duplicate
wrng.End = wrng.End - 1
wrng.EndOf
wrng.Text = "</hi>"
End If
srchResult.Start = wrng.End + addOn
srchResult.End = rngToSearch.End
If loopCt > 10 Then Exit Do
Loop Until Not srchResult.Find.Found
End Sub
Sub replaceAllEmptyP()
Attribute replaceAllEmptyP.VB_Description = "Macro recorded 8/18/2003 by Than G"
Attribute replaceAllEmptyP.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.replaceAllP"
'
' replaceAllP Macro
' Macro recorded 8/18/2003 by Than G
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "<p></p>"
.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
Sub convertItalics()
Attribute convertItalics.VB_Description = "Macro recorded 8/18/2003 by Than G"
Attribute convertItalics.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.searchItalics"
'
' searchItalics Macro
' Macro recorded 8/18/2003 by Than G
'
Dim rngToSearch, srchResult As Range
Dim textRun, openTag, endTage As String
Dim resInt, loopCt As Integer
loopCt = 0
unItalicizeCommas
Load ItalicOptions
ItalicOptions.Hide
Set rngToSearch = ActiveDocument.Range.Duplicate
If ActiveDocument.Tables.Count > 0 Then
rngToSearch.Start = ActiveDocument.Tables(1).Range.End + 1
End If
Set srchResult = rngToSearch.Duplicate
Do
loopCt = loopCt + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Or loopCt > 200 Then Exit Do
If InStr(srchResult.Style, "Heading") = 0 And Not isCharStyle(srchResult) Then
textRun = srchResult.Text
ItalicOptions.ItalText.Caption = textRun
ItalicOptions.Show
If ItalicOptions.wasCancelled Then
Unload ItalicOptions
Exit Sub
End If
srchResult.Style = ItalicOptions.getSelectedStyle()
If ItalicOptions.getSelectedStyle() = "Normal,no" Then
srchResult.Font.Italic = False
End If
End If
srchResult.Start = srchResult.End + 1
srchResult.End = rngToSearch.End
Loop Until Not srchResult.Find.Found
convertFootnoteItalics
End Sub
Sub convertFootnoteItalics()
Dim loopCt As Integer
ActiveDocument.Endnotes.Convert
For n = 1 To ActiveDocument.Footnotes.Count
Set rngToSearch = ActiveDocument.Footnotes(n).Range.Duplicate
Set srchResult = rngToSearch.Duplicate
loopCt = 0
Do
loopCt = loopCt + 1
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Or loopCt > 20 Then Exit Do
If InStr(srchResult.Style, "Heading") = 0 And Not isCharStyle(srchResult) Then
textRun = srchResult.Text
ItalicOptions.ItalText.Caption = textRun
ItalicOptions.Show
If ItalicOptions.wasCancelled Then
Unload ItalicOptions
Exit Sub
End If
srchResult.Style = ItalicOptions.getSelectedStyle()
If ItalicOptions.getSelectedStyle() = "Normal,no" Then
srchResult.Font.Italic = False
End If
End If
srchResult.Start = srchResult.End + 2
srchResult.End = rngToSearch.End
Loop Until Not srchResult.Find.Found
Next n
End Sub
Sub doCharacterStyles()
Dim styleData(50, 3) As String
Dim styleCount As Integer
Dim rngToSearch, srchResult, wrng As Range
styleData(1, 1) = "Emphasis Weak,ew": styleData(1, 2) = "<hi rend=""weak"">": styleData(1, 3) = "</hi>"
styleData(2, 1) = "Text Title,tt": styleData(2, 2) = "<title>": styleData(2, 3) = "</title>"
styleData(3, 1) = "Lang Tibetan,tib": styleData(3, 2) = "<foreign lang=""tib"">": styleData(3, 3) = "</foreign>"
styleData(4, 1) = "Lang Sanskrit,san": styleData(4, 2) = "<foreign lang=""san"">": styleData(4, 3) = "</foreign>"
styleData(5, 1) = "Lang Chinese,chi": styleData(5, 2) = "<foreign lang=""chi"">": styleData(5, 3) = "</foreign>"
styleData(6, 1) = "Lang Japanese,jap": styleData(6, 2) = "<foreign lang=""jap"">": styleData(6, 3) = "</foreign>"
styleData(7, 1) = "Name Personal Human,nph": styleData(7, 2) = "<persName type=""human"">": styleData(7, 3) = "</persName>"
styleData(8, 1) = "Name Personal other,npo": styleData(8, 2) = "<persName type=""other"">": styleData(8, 3) = "</persName>"
styleData(9, 1) = "Name Place,np": styleData(9, 2) = "<placeName>": styleData(9, 3) = "</placeName>"
styleData(10, 1) = "Name organization,nor": styleData(10, 2) = "<orgName>": styleData(10, 3) = "</orgName>"
styleData(11, 1) = "Reference,rf": styleData(11, 2) = "<ref type=""bibl"">": styleData(11, 3) = "</ref>"
styleData(12, 1) = "Emphasis Strong,es": styleData(12, 2) = "<hi rend=""strong"">": styleData(12, 3) = "</hi>"
styleData(13, 1) = "Dates , dt": styleData(13, 2) = "<date>": styleData(13, 3) = "</date>"
styleCount = 13
For x = 1 To styleCount
Set rngToSearch = ActiveDocument.Range
Set srchResult = rngToSearch.Duplicate
y = 0
Do
Application.StatusBar = "Proceessing document: processing character styles (" & styleData(x, 1) & ")! " & y
With srchResult.Find
.ClearFormatting
.Format = True
.Style = styleData(x, 1)
.Text = ""
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If Not srchResult.Find.Found Or InStr(srchResult.Text, "</hi></hi>") > 0 Then Exit Do
Set wrng = fixRange(srchResult.Duplicate)
wrng.Select
Selection.Style = "Plain Text"
wrng.StartOf
wrng.Text = styleData(x, 2)
wrng.Select
Selection.Style = "Plain Text"
Set wrng = srchResult.Duplicate
wrng.EndOf
wrng.Text = styleData(x, 3)
wrng.Select
Selection.Style = "Plain Text"
srchResult.Start = wrng.End + Len(styleData(x, 3))
srchResult.End = rngToSearch.End
50 y = y + 1
If y > 100 Then Exit Do
Loop Until Not srchResult.Find.Found
Next x
Application.StatusBar = "Proceessing document: processing character styles in footnotes!"
For n = 1 To ActiveDocument.Footnotes.Count
For x = 1 To styleCount
Application.StatusBar = "Proceessing document: processing footnote character styles (" & styleData(x, 1) & ")!"
Set rngToSearch = ActiveDocument.Footnotes(n).Range
Set srchResult = rngToSearch.Duplicate
y = 0
Do
With srchResult.Find
.ClearFormatting
.Format = True
.Style = styleData(x, 1)
.Text = ""
.Wrap = wdFindStop
.Forward = True
.Execute
End With
If srchResult.Find.Found = False Or InStr(srchResult.Text, "</hi></hi>") > 0 Then Exit Do
Set wrng = fixRange(srchResult.Duplicate)
wrng.Select
Selection.Style = "Plain Text"
wrng.StartOf
wrng.Text = styleData(x, 2)
wrng.Select
Selection.Style = "Plain Text"
Set wrng = srchResult.Duplicate
wrng.EndOf
wrng.Text = styleData(x, 3)
wrng.Select
Selection.Style = "Plain Text"
srchResult.Start = wrng.End + Len(styleData(x, 2)) + Len(styleData(x, 3)) + 2
srchResult.End = rngToSearch.End
100 y = y + 1
If y > 10 Then Exit Do
Loop Until Not srchResult.Find.Found
Next x
Next n
End Sub
Function isCharStyle(ByVal rng As Range) As Boolean
styleName = rng.Style
isCharStyle = False
If styleName = "Emphasis Weak,ew" Then
isCharStyle = True
ElseIf styleName = "Text Title,tt" Then
isCharStyle = True
ElseIf styleName = "Lang Tibetan,tib" Then
isCharStyle = True
ElseIf styleName = "Lang Sanskrit,san" Then
isCharStyle = True
ElseIf styleName = "Lang Chinese,chi" Then
isCharStyle = True
ElseIf styleName = "Lang Japanese,jap" Then
isCharStyle = True
ElseIf styleName = "Name Personal Human,nph" Then
isCharStyle = True
ElseIf styleName = "Name Personal other,npo" Then
isCharStyle = True
ElseIf styleName = "Name Place,np" Then
isCharStyle = True
ElseIf styleName = "Name organization,nor" Then
isCharStyle = True
End If
End Function
Sub unItalicizeCommas()
Attribute unItalicizeCommas.VB_Description = "Macro recorded 8/19/2003 by Than G"
Attribute unItalicizeCommas.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.unItalicizeCommas"
'
' unItalicizeCommas Macro
' Macro recorded 8/19/2003 by Than G
'
Dim rngToSearch, srchResult As Range
Set rngToSearch = ActiveDocument.Range.Duplicate
Set srchResult = rngToSearch.Duplicate
Do
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ","
.Font.Italic = True
.Wrap = wdFindStop
.Forward = True
.MatchWildcards = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
srchResult.Font.Italic = False
srchResult.Start = srchResult.End + 1
srchResult.End = rngToSearch.End
Loop Until Not srchResult.Find.Found
For n = 1 To ActiveDocument.Footnotes.Count
Set rngToSearch = ActiveDocument.Footnotes(n).Range
Set srchResult = rngToSearch.Duplicate
Do
With srchResult.Find
.ClearFormatting
.Format = True
.Text = ","
.Font.Italic = True
.Wrap = wdFindStop
.Forward = True
.MatchWildcards = True
.Execute
End With
If Not srchResult.Find.Found Then Exit Do
srchResult.Font.Italic = False
srchResult.Start = srchResult.End + 1
srchResult.End = rngToSearch.End
Loop Until Not srchResult.Find.Found
Next n
End Sub
Sub replaceEntities()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "&"
.Replacement.Text = "&amp;"
.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 = "&lt;"
.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 = "&gt;"
.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
Reference in a new issue Copy permalink