Word Macros
From notebook
Sub AAAtemp() ' ' AAAtemp Macro ' 作成日 2011/01/26 作成者 Takemoto Timothy '
End Sub Sub red() ' ' red Macro ' 記録日 2004/06/14 記録者 Takemoto Timothy '
With Selection.Font .NameFarEast = "MS 明朝" .NameAscii = "Comic Sans MS" .NameOther = "Comic Sans MS" .Name = "Comic Sans MS" .Size = 10.5 .Bold = False .Italic = False .Underline = wdUnderlineDash .UnderlineColor = wdColorRed .StrikeThrough = False .DoubleStrikeThrough = False .Outline = False .Emboss = False .Shadow = False .Hidden = False .SmallCaps = False .AllCaps = False .Color = wdColorAutomatic .Engrave = False .Superscript = False .Subscript = False .Spacing = 0 .Scaling = 100 .Position = 0 .Kerning = 1 .Animation = wdAnimationNone .DisableCharacterSpaceGrid = False .EmphasisMark = wdEmphasisMarkNone End With
End Sub
Sub Red_underline_footer() ' ' re_underline_footer Macro ' 記録日 2005/09/22 記録者 Takemoto Timothy '
Selection.Copy If ActiveWindow.View.SplitSpecial <> wdPaneNone Then ActiveWindow.Panes(2).Close End If If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _ ActivePane.View.Type = wdOutlineView Then ActiveWindow.ActivePane.View.Type = wdPrintView End If ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter Selection.EndKey Unit:=wdStory Selection.Paste Selection.TypeText Text:=", " ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument With Selection.Font .Underline = wdUnderlineDash .UnderlineColor = wdColorRed End With
End Sub Sub moodlemodelinefeedremover() ' ' moodlemodelinefeedremover Macro ' 記録日 2005/11/28 記録者 Takemoto Timothy '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^l" .Replacement.Text = "^p" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = False End With Selection.Find.Execute Replace:=wdReplaceAll
End Sub Sub PrepareGIFT() ' ' GIFT_pre Macro ' 記録日 2005/11/30 記録者 Yasuko ' ' Remove line feeds as opposed to carriage returns ' '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^l" .Replacement.Text = "^p" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = False End With Selection.Find.Execute Replace:=wdReplaceAll
' Replace Two byte "{" with single byte '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "}" .Replacement.Text = "}" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = True .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = False End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Replace two byte "}" with single byte '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "{" .Replacement.Text = "{" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = True .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = False End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Make sure that there are "{" after all question marks. '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "\?^13" .Replacement.Text = "? {^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Make sure that there are "{" after all question marks. 'with trailing spaces
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "\? {1,}^13" .Replacement.Text = "? {^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Make sure that there are "." at the end of all 'non command charcter (i.e. question and question-end) 'and blank lines '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "([A-z])^13" .Replacement.Text = "\1.^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Remove extra space after full stop '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ". {1,}^13" .Replacement.Text = ".^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' ' Convert triple returns to "return } return return" ' This is because I am used to putting in the '}' ' but sometimes I forget. '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^13^13^13" .Replacement.Text = "^13}^13^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' ' Convert blank lines follow by questions ' To close the previous question with a "}" '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ".^13^13([A-z]*?)" .Replacement.Text = "^13}^13^13\1" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' 'First parse on wrong answers '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "([!\}^13])^13([!=\}^13])(*.)^13" .Replacement.Text = "\1^13~\2\3#間違いです。^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Second parse on wrong answers looking for exclamation marks 'This was in fact Japanese fulls stopsin my version. 'This second parse needs to look for wrong answers that 'follow wrong answers.
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "(\。)^13([!=\}^13])(*.)^13" .Replacement.Text = "\1^13~\2\3#間違いです。^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
' 'Correct answers '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "(=*.)^13" .Replacement.Text = "\1#正解です。^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll
End Sub Sub AIKENtoGIFT() ' ' AIKENtoGIFT Macro ' 記録日 2005/12/02 記録者 Takemoto Timothy '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "ANSWER: ([A-z])" .Replacement.Text = "\1" .Forward = True .Wrap = wdFindAsk .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With Selection.Find.Execute Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "ANSWER: ([A-z])" .Replacement.Text = "\1" .Forward = True .Wrap = wdFindAsk .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchFuzzy = False .MatchWildcards = True End With With Selection If .Find.Forward = True Then .Collapse Direction:=wdCollapseStart Else .Collapse Direction:=wdCollapseEnd End If .Find.Execute Replace:=wdReplaceOne If .Find.Forward = True Then .Collapse Direction:=wdCollapseEnd Else .Collapse Direction:=wdCollapseStart End If .Find.Execute End With With Selection If .Find.Forward = True Then .Collapse Direction:=wdCollapseStart Else .Collapse Direction:=wdCollapseEnd End If .Find.Execute Replace:=wdReplaceOne If .Find.Forward = True Then .Collapse Direction:=wdCollapseEnd Else .Collapse Direction:=wdCollapseStart End If .Find.Execute End With
End Sub Sub Red_bold() ' ' Red_bold Macro uses Shift R key (was used to close file) ' 記録日 2006/08/11 記録者 Takemoto Timothy '
With Selection.Font .Bold = True .Color = wdColorRed End With
End Sub Sub space_to_underline_no_punctuation() ' ' space_to_underline_no_punctuation Macro ' 記録日 2006/12/14 記録者 Takemoto Timothy '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = " " .Replacement.Text = "_" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "?" .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "'" .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = """" .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "," .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = ";" .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = ":" .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ":" .Replacement.Text = "" .Forward = True .Wrap = False .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = True Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.TypeText Text:="Vars_" End With
End Sub Sub temp() ' ' temp Macro ' 記録日 2006/12/14 記録者 Takemoto Timothy '
Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.TypeText Text:="Vars_"
End Sub
Sub Paste_As_Unformatted_Text() ' ' Paste_As_Unformatted_Text Macro ' 作成日 2006/12/29 作成者 Takemoto Timothy ' http://www.tutorialized.com/tutorial/Automate-Away-Annoyances-with-Macros/10191 '
Selection.PasteSpecial Link:=False, DataType:=wdPasteText, _ Placement:=wdInLine, DisplayAsIcon:=False
End Sub Sub spacetwodot() ' ' spacetwodot Macro ' 記録日 2007/03/15 記録者 Takemoto Timothy '
Selection.TypeText Text:=" " Selection.Delete Unit:=wdCharacter, Count:=1 Selection.Delete Unit:=wdCharacter, Count:=1
End Sub
Sub Macro1() ' ' Macro1 Macro ' 記録日 2007/08/10 記録者 Takemoto Timothy '
Selection.Style = ActiveDocument.Styles("見出し 2")
End Sub
Sub Remove_questions() ' ' Remove_questions Macro ' '
Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^13*\? " .Replacement.Text = "^13" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True .MatchFuzzy = False End With Selection.Find.Execute Replace:=wdReplaceAll
End Sub