Макрос разметки MS Word

Материал из PraxOS

Перейти к: навигация, поиск

SubWord2MediaWiki()

Application.ScreenUpdating=False
ReplaceQuotes
MediaWikiEscapeChars
MediaWikiConvertHyperlinks
MediaWikiConvertH1
MediaWikiConvertH2
MediaWikiConvertH3
MediaWikiConvertH4
MediaWikiConvertH5
MediaWikiConvertItalic
MediaWikiConvertBold
MediaWikiConvertUnderline
MediaWikiConvertStrikeThrough
MediaWikiConvertSuperscript
MediaWikiConvertSubscript
MediaWikiConvertLists
MediaWikiConvertTables
'Copytoclipboard
ActiveDocument.Content.Copy
Application.ScreenUpdating=True

EndSub

PrivateSubMediaWikiConvertH1()

ReplaceHeadingwdStyleHeading1,"="

EndSub

PrivateSubMediaWikiConvertH2()

ReplaceHeadingwdStyleHeading2,"=="

EndSub

PrivateSubMediaWikiConvertH3()

ReplaceHeadingwdStyleHeading3,"==="

EndSub

PrivateSubMediaWikiConvertH4()

ReplaceHeadingwdStyleHeading4,"===="

EndSub

PrivateSubMediaWikiConvertH5()

ReplaceHeadingwdStyleHeading5,"====="

EndSub

PrivateSubMediaWikiConvertBold()

ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Font.Bold=True
.Text=""
.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
IfLen(.Text)>1AndInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBefore""
.InsertAfter""
EndIf
.Style=ActiveDocument.Styles("DefaultParagraphFont")
.Font.Bold=False
EndWith
Loop
EndWith

EndSub


PrivateSubMediaWikiConvertItalic()

ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Font.Italic=True
.Text=""
.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
IfLen(.Text)>1AndInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBefore""
.InsertAfter""
EndIf
.Style=ActiveDocument.Styles("DefaultParagraphFont")
.Font.Italic=False
EndWith
Loop
EndWith

EndSub


PrivateSubMediaWikiConvertUnderline()

ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Font.Underline=True
.Text=""
.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
IfLen(.Text)>1AndInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBefore""
.InsertAfter""
EndIf
.Style=ActiveDocument.Styles("DefaultParagraphFont")
.Font.Underline=False
EndWith
Loop
EndWith

EndSub


PrivateSubMediaWikiConvertStrikeThrough()

ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Font.StrikeThrough=True
.Text=""
.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
IfLen(.Text)>1AndInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBefore"-"
.InsertAfter"-"
EndIf
.Style=ActiveDocument.Styles("DefaultParagraphFont")
.Font.StrikeThrough=False
EndWith
Loop
EndWith

EndSub


PrivateSubMediaWikiConvertSuperscript()

ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Font.Superscript=True
.Text=""
.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
.Text=Trim(.Text)
IfLen(.Text)>1AndInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBefore"^"
.InsertAfter"^"
EndIf
.Style=ActiveDocument.Styles("DefaultParagraphFont")
.Font.Superscript=False
EndWith
Loop
EndWith

EndSub


PrivateSubMediaWikiConvertSubscript()

ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Font.Subscript=True
.Text=""
.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
.Text=Trim(.Text)
IfLen(.Text)>1AndInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBefore"~"
.InsertAfter"~"
EndIf
.Style=ActiveDocument.Styles("DefaultParagraphFont")
.Font.Subscript=False
EndWith
Loop
EndWith

EndSub


PrivateSubMediaWikiConvertLists()

DimparaAsParagraph
ForEachparaInActiveDocument.ListParagraphs
Withpara.Range
.InsertBefore""
Fori=1To.ListFormat.ListLevelNumber
If.ListFormat.ListType=wdListBulletThen
.InsertBefore"*"
Else
.InsertBefore"#"
EndIf
Nexti
.ListFormat.RemoveNumbers
EndWith
Nextpara

EndSub


PrivateSubMediaWikiConvertTables()

DimthisTableAsTable
ForEachthisTableInActiveDocument.Tables
WiththisTable
ForEachaRowInthisTable.Rows
WithaRow
ForEachaCellInaRow.Cells
WithaCell
aCell.Range.InsertBefore"|"
'aCell.Range.InsertAfter"|"
EndWith
NextaCell
'.Range.InsertBefore"|"
.Range.InsertAftervbCrLf+"|-"
EndWith
NextaRow
.Range.InsertBefore"{|"+vbCrLf
.Range.InsertAftervbCrLf+"|}"
.ConvertToText"|"
EndWith
NextthisTable

EndSub


PrivateSubMediaWikiConvertHyperlinks()

DimhyperCountAsInteger
hyperCount=ActiveDocument.Hyperlinks.Count
Fori=1TohyperCount
WithActiveDocument.Hyperlinks(1)
DimaddrAsString
addr=.Address
.Delete
.Range.InsertBefore"["
.Range.InsertAfter"-"&addr&"]"
EndWith
Nexti

EndSub


'Replaceallsmartquoteswiththeirdumbequivalents

PrivateSubReplaceQuotes()

DimquotesAsBoolean
quotes=Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes=False
ReplaceStringChrW(8220),""""
ReplaceStringChrW(8221),""""
ReplaceString"‘","'"
ReplaceString"’","'"
Options.AutoFormatAsYouTypeReplaceQuotes=quotes

EndSub


PrivateSubMediaWikiEscapeChars()

EscapeCharacter"*"
EscapeCharacter"#"
'EscapeCharacter"_"
'EscapeCharacter"-"
'EscapeCharacter"+"
EscapeCharacter"{"
EscapeCharacter"}"
EscapeCharacter"["
EscapeCharacter"]"
EscapeCharacter"~"
EscapeCharacter"^^"
EscapeCharacter"|"
EscapeCharacter"'"

EndSub


PrivateFunctionReplaceHeading(styleHeadingAsString,headerPrefixAsString)

DimnormalStyleAsStyle
SetnormalStyle=ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
WithSelection.Find
.ClearFormatting
.Style=ActiveDocument.Styles(styleHeading)
.Text=""


.Format=True
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.Forward=True
.Wrap=wdFindContinue
DoWhile.Execute
WithSelection
IfInStr(1,.Text,vbCr)Then
'Justprocessthechunkbeforeanynewlinecharacters
'We'llpick-uptherestwiththenextsearch
.Collapse
.MoveEndUntilvbCr
EndIf
'Don'tbothertomarkupnewlinecharacters(preventsaloop,aswell)
IfNot.Text=vbCrThen
.InsertBeforeheaderPrefix
.InsertBeforevbCr
.InsertAfterheaderPrefix
EndIf
.Style=normalStyle
EndWith
Loop
EndWith

EndFunction

PrivateFunctionEscapeCharacter(charAsString)

ReplaceStringchar,"\"&char

EndFunction

PrivateFunctionReplaceString(findStrAsString,replacementStrAsString)

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
WithSelection.Find
.Text=findStr
.Replacement.Text=replacementStr
.Forward=True
.Wrap=wdFindContinue
.Format=False
.MatchCase=False
.MatchWholeWord=False
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
EndWith
Selection.Find.ExecuteReplace:=wdReplaceAll

EndFunction