Word Macros

From notebook

Revision as of 07:58, 26 January 2011 by Timtak (Talk | contribs)
(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search

Sub AAAtemp() ' ' AAAtemp Macro ' 作成日 2011/01/26 作成者 Takemoto Timothy '

End Sub Sub red() ' ' red Macro ' 記録日 2004/06/14 記録者 Takemoto Timothy ' 

   With Selection.Font
       .NameFarEast = "ＭＳ 明朝"
       .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 re_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

Retrieved from "http://nihonbunka.com/wiki/index.php?title=Word_Macros"
Personal tools