Date = October 16, 1997, File = G:\scratch.doc 67
John Miyamoto
Word Macro Code, 1/11/2007; JMMX.dotm attached on 1/17/2012.
Date = October 16, 1997, File = G:\scratch.doc 67
*********** 'My' module in JMM.DOT **************
'======
Public Sub AddBookmark(NewBookmark As String)
'
' AddBookmark Macro
' Add bookmark to current document
'
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:=NewBookmark
End Sub
'======
Public Sub AscNum()
' Gives the Ascii code and the Ascii W code for selected character.
MsgBox ("Ascii number for the highlighted character is: " & Asc(Selection.Text))
MsgBox ("Ascii W number for the highlighted character is: " & AscW(Selection.Text))
End Sub
'======
Sub AddEdit()
'
' AddEdit Macro
' Attach 'edit.dot' template as an AddIn.
'
AddIns.Add FileName:="E:\cm\templats\Edit.dot", Install:=True
With ActiveDocument
.UpdateStylesOnOpen = True
.AttachedTemplate = "E:\cm\templats\jmm.dot"
.XMLSchemaReferences.AutomaticValidation = True
.XMLSchemaReferences.AllowSaveAsXMLWithoutValidation = False
End With
End Sub
'======
Sub AddR()
'
' AddR Macro
' The AddR macro attaches R.Dot as an AddIn.
'
AddIns("D:\Program Files\MathType50\Office Support\WordCmds.dot"). _
Installed = False
AddIns("E:\PDFMaker.dot").Installed = False
AddIns("E:\NORMAL.DOT").Installed = False
AddIns("C:\PROGRAM FILES\MICROSOFT OFFICE\OFFICE\STARTUP\WordSmith.dot"). _
Installed = False
AddIns("C:\PROGRAM FILES\MICROSOFT OFFICE\OFFICE\STARTUP\PALMAPP.DOT"). _
Installed = False
AddIns("E:\cm\templats\r.dot").Install = True
With ActiveDocument
.UpdateStylesOnOpen = True
.AttachedTemplate = "E:\cm\templats\jmm.dot"
End With
End Sub
'======
Sub assignkey()
' Assigns a macro to Ctrl-Shift-J. Ok 3/19/01.
macname$ = InputBox("Assign Macro to Hot Key", "Input macro name", "")
KeyChoice = InputBox("Indicate the key to be used as your hot key. Your choices are:" & Chr(13) & _
"1 == Ctrl-Shift-J (currently unassigned)" & Chr(13) & _
"2 == Ctrl-, (currently assigned to prefix key)" & Chr(13) & _
"3 == Ctrl-. (currently unassigned)" & Chr(13) & _
"4 == Ctrl-/ (currently assigned to prefix key)" & Chr(13) & _
"5 == Ctrl-Shift-? (currently unassigned)", "Assign Hot Key")
If (KeyChoice = 1) Then
CustomizationContext = ActiveDocument.AttachedTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyJ, wdKeyControl, wdKeyShift), _
KeyCategory:=wdKeyCategoryMacro, Command:=macname$
End If
If (KeyChoice = 2) Then
CustomizationContext = ActiveDocument.AttachedTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyComma, wdKeyControl), _
KeyCategory:=wdKeyCategoryMacro, Command:=macname$
End If
If (KeyChoice = 3) Then
CustomizationContext = ActiveDocument.AttachedTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyPeriod, wdKeyControl), _
KeyCategory:=wdKeyCategoryMacro, Command:=macname$
End If
If (KeyChoice = 4) Then
CustomizationContext = ActiveDocument.AttachedTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeySlash, wdKeyControl), _
KeyCategory:=wdKeyCategoryMacro, Command:=macname$
End If
If (KeyChoice = 5) Then
CustomizationContext = ActiveDocument.AttachedTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeySlash, wdKeyControl, wdKeyShift _
), KeyCategory:=wdKeyCategoryMacro, Command:=macname$
End If
End Sub
'======
Sub AttachNormal()
'
' AttachNormal Macro
' Attach normal template to current document
'
With ActiveDocument
.UpdateStylesOnOpen = True
.AttachedTemplate = "E:\cm\TEMPLATS\Normal.dot"
End With
End Sub
'======
Sub big()
'
' tmbig Macro
' Attach bigfont.dot and makes jmm.dot an add-in.
'
AddIns("E:\PDFMaker.dot").Installed = False
AddIns("C:\PROGRAM FILES\MICROSOFT OFFICE\OFFICE\STARTUP\WordSmith.dot"). _
Installed = False
AddIns("C:\PROGRAM FILES\MICROSOFT OFFICE\OFFICE\STARTUP\PALMAPP.DOT"). _
Installed = False
AddIns("E:\cm\templats\JMM.DOT").Installed = True
End Sub
'======
Public Sub BlankToTab()
' Macro 'BlankToTab' replaces every sequence of consecutive blanks with one tab.
Dim CountVar As Integer
Dim bs1 As String, bs2 As String
Dim BlanksNotFound As Boolean
AddBookmark ("tmInitial")
CountVar = 0
bs1 = ""
Do
bs1 = bs1 & " "
Selection.Find.ClearFormatting
With Selection.Find
.Text = bs1
.Replacement.Text = ""
.Forward = True 'Direction choices: True, False
.Wrap = wdFindStop 'Wrap choices: wdFindContinue, wdFindAsk, wdFindStop
.MatchCase = False
.MatchWholeWord = False
.Format = False
End With
Selection.Find.Execute
BlanksNotFound = Not Selection.Find.Found
GoToBook ("tmInitial")
Loop Until BlanksNotFound
CountVar = Len(bs1)
bs2 = bs1
For I = 1 To (CountVar - 1)
bs2 = Left(bs1, CountVar - I)
GoToBook ("tmInitial")
Selection.Find.ClearFormatting
With Selection.Find
.Text = bs2
.Replacement.Text = Chr(9)
.Forward = True 'Direction choices: True, False
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = False
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
End Sub 'end def 'BlankToTab'
'======
Sub bnd()
' Put border around figure or paragraph.
With Selection.ParagraphFormat
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.ColorIndex = wdAuto
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.ColorIndex = wdAuto
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.ColorIndex = wdAuto
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.ColorIndex = wdAuto
End With
End With
End Sub
'======
Sub box()
'
' box Macro
' Put box around highlighted text
'
With Selection.Font
With .Borders(1)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
.Borders.Shadow = False
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth100pt
.DefaultBorderColor = wdColorAutomatic
End With
End Sub
'======
Public Sub Cap()
Dim NumChars As Integer
Dim AskBeforeCap As Boolean, CapDecis As Boolean, IsFontItalicized As Boolean
Dim aa1 As String, bb1 As String
AddBookmark ("tmCurrentSelection")
NumChars = Selection.Characters.Count
AskBeforeCap = (MsgBox( _
"Ask the user whether to capitalize a letter, or make capitalization decisions automatically?" & _
Chr(13) & Chr(13) & _
"YES = Ask before each capitalization action, NO = Automatically capitalize 1st letters of words", _
vbYesNo, "Automatic or User-Controlled Capitalization?") = vbYes)
Selection.EscapeKey
Selection.Collapse
For I = 1 To NumChars - 2
CapDecis = True
If I > 2 Then
Selection.EscapeKey
Selection.Collapse
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
aa1 = Selection.Text
End If 'end "If I > 2"
If I = 2 Then
Selection.EscapeKey
Selection.Collapse
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
aa1 = Selection.Text
End If
If I = 1 Then aa1 = " "
SelectNextChar
bb1 = Selection.Text
If (aa1 = " " Or aa1 = Chr(13) Or aa1 = Chr(11) Or aa1 = "(" Or Is_Dash(aa1)) And _
Is_Lower(bb1) Then
If AskBeforeCap Then
BoxRes = MsgBox( _
"Capitalize the selected character?" & Chr(13) & Chr(13) & _
"YES = Capitalize, NO = Don't capitalize, CANCEL = Exit macro", vbYesNoCancel)
If BoxRes = vbCancel Then End
CapDecis = (BoxRes = vbYes)
End If 'end "If AskBeforeCap"
If CapDecis Then
IsFontItalicized = Selection.Font.Italic
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Font.Italic = IsFontItalicized
Selection.TypeText Text:=UCase(bb1)
If I = NumChars - 2 Then
SelectToBookmark ("tmCurrentSelection")
AddBookmark ("tmCurrentSelection")
End If 'end "If I = NumChars - 2"
End If 'end "If CapDecis
End If 'end "If (aa1 = " " Or aa1 = Chr(13) Or aa1 = Chr(11) Or aa1 = "(") And Is_Lower(bb1) "
Selection.EscapeKey
Selection.MoveRight Unit:=wdCharacter, Count:=1
Next I 'end 'For I = 1 to NumChars - 2
Selection.EscapeKey
GoToBook ("tmCurrentSelection")
End Sub 'end def 'cap'
'======
Public Sub Char()
cc1% = InputBox("Look up character that corresponds to number: ")
' MsgBox ("Characters = '" & Chr(cc1%) & "'")
Selection.TypeText Text:=Chr(cc1%)
End Sub
'======
Sub ClipList()
' Shows the toolbar with the list of clipboard contents. Ok 3/19/01.
CommandBars("Clipboard").Visible = True
End Sub
'======
Sub cnvtab()
' Converts a table to text. Fields separated by commas. Ok 3/19/01.
Selection.Tables(1).Select
Selection.Rows.ConvertToText Separator:=wdSeparateByCommas, NestedTables:= _
True
Selection.Fields.Unlink
End Sub
'======
Sub ColWidth()
' Assign column width to column containing current cursor position.
' Revised 3/18/01
Application.Run MacroName:="SelectColumn"
tmx = PointsToInches(Selection.Columns.Width)
CW$ = InputBox("Input column width, e.g., 1.0", _
"Input Column Width", Str(tmx))
If CW$ = "auto" Then
Selection.Cells.SetWidth ColumnWidth:=wdAutoPosition _
, RulerStyle:=wdAdjustNone
Else
Selection.Cells.SetWidth ColumnWidth:=InchesToPoints(Val(CW$)) _
, RulerStyle:=wdAdjustNone
End If
End Sub
'======
Sub del_linefeed()
'
' 'del_linefeed' macro replaces line feeds with commas.
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " ^l"
.Replacement.Text = ", "
.Forward = False
.Wrap = wdFindAsk
.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 = " ^l"
.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
With Selection.Find
.Text = "^l"
.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 dlf()
' Delete line feeds; replace with comma.
Application.Run MacroName:="del_linefeed"
End Sub
'======
Sub DelEditMacs()
'
' DelEditMacs Macro
' Delete the Edit.Dot macros from the current document
'
Application.DisplayAutoCompleteTips = True
NormalTemplate.AutoTextEntries("Filename and path").Insert Where:= _
Selection.Range, RichText:=True
Selection.MoveLeft Unit:=wdWord, Count:=1
Selection.Fields.Unlink
docloc$ = Selection.Text
Selection.Delete Unit:=wdCharacter, Count:=1
Application.OrganizerDelete Source:=docloc$, Name:="EditMacs", _
Object:=wdOrganizerObjectProjectItems
End Sub
'======
Sub DelOptionalHyphen()
' Macro deletes all optional hyphens within a selection or from the current cursor
' position to the end of the file if no selection has been made.
'
CurrentDisplay = ActiveWindow.View.ShowAll
ActiveWindow.View.ShowAll = True
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^-"
.Replacement.Text = ""
.Forward = True
.Wrap = False
.Format = False
.MatchCase = False
.MatchWholeWord = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
ActiveWindow.View.ShowAll = CurrentDisplay
End Sub
'======
Sub delpara()
' Delete paragraph marks to reformat email messages.
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^l"
.Replacement.Text = ", ^p"
.Forward = True
.Wrap = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p "
.Replacement.Text = "@#@"
.Forward = True
.Wrap = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' ********
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "@#@"
.Forward = True
.Wrap = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' ********
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " ^p"
.Replacement.Text = " "
.Forward = True
.Wrap = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' ********
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
.Forward = True
.Wrap = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' ********
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "@#@"
.Replacement.Text = "^p"
.Forward = True
.Wrap = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
'======
Sub delrep()
'
' delrep Macro
' Repeat search, query,and if yes, delete and replace with content of clipboard.
'
Selection.Find.Execute
'
If MsgBox("Delete this text?", vbYesNo) = vbYes Then
Selection.Delete Unit:=wdCharacter, Count:=1
Application.Run MacroName:="MathTypeCommands.UIWrappers.EditPaste"
End If
End Sub
'======
Sub eq2()
' Insert Version 3.0 Equation Object. Ok 3/19/01.
Selection.InlineShapes.AddOLEObject ClassType:="Equation.3", FileName:="", _
LinkToFile:=False, DisplayAsIcon:=False
End Sub
'======
Sub f()
'
' f Macro
' Improved search procedure
'
SString$ = InputBox("Enter search string")
SearchType$ = InputBox("Enter search type" & Chr(13) & Chr(13) & _
"1xxx = +forward, 2xxx = -forward" & Chr(13) & _
"x1xx = +wrap, x2xx = -wrap, w3xx = Ask" & Chr(13) & _
"xx1x = +match case, xx2x = -match case" & Chr(13) & _
"xxx1 = +whole word, xxx2 = -whole word", "Search", "1222")
cc1$ = Mid(SearchType$, 1, 1)
cc2$ = Mid(SearchType$, 2, 1)
cc3$ = Mid(SearchType$, 3, 1)
cc4$ = Mid(SearchType$, 4, 1)
If (cc1$ = "1") Then
Flag1 = True
Else
If (cc1$ = "2") Then
Flag1 = False
Else
MsgBox ("Error: Illegal digit 1. Input code was '" & SearchType$ & "'")
Exit Sub
End If
End If
If (cc2$ = "1") Then
Flag2 = wdFindContinue
Else
If (cc2$ = "2") Then
Flag2 = wdFindStop
Else
If (cc2$ = "3") Then
Flag2 = wdFindAsk
Else
MsgBox ("Error: Illegal digit 2. Input code was '" & SearchType$ & "'")
Exit Sub
End If
End If
End If
If (cc3$ = "2") Then
Flag3 = False
Else
If (cc3$ = "1") Then
Flag3 = True
Else
MsgBox ("Error: Illegal digit 3. Input code was '" & SearchType$ & "'")
Exit Sub
End If
End If
If (cc4$ = "1") Then
Flag4 = True
Else
If (cc4$ = "2") Then
Flag4 = False
Else
MsgBox ("Error: Illegal digit 4. Input code was '" & SearchType$ & "'")
Exit Sub
End If
End If
Selection.Find.ClearFormatting
With Selection.Find
.Text = SString$
.Forward = Flag1
.Wrap = Flag2
.Format = False
.MatchCase = Flag3
.MatchWholeWord = Flag4
End With
Selection.Find.Execute
If (Not Selection.Find.Found) Then MsgBox ("String '" & SString$ & "' not found." & _
Chr(13) & Chr(13) & ".Forward = " & Flag1 & Chr(13) & ".Wrap = " & Flag2 & _
Chr(13) & ".MatchCase = " & Flag3 & Chr(13) & ".MatchWholeWord = " & Flag4)
End Sub
'======
Sub fot()
' (Re)format styles ot1 and ot2 to conform to JMM.DOT. Ok 3/19/01.
Application.OrganizerCopy Source:="E:\cm\templats\save\jmm.z060331.dot", _
Destination:=ActiveDocument.FullName, Name:="ot1", Object:= _
wdOrganizerObjectStyles
Application.OrganizerCopy Source:="E:\cm\templats\save\jmm.z060331.dot", _
Destination:=ActiveDocument.FullName, Name:="ot2", Object:= _
wdOrganizerObjectStyles
End Sub
'======
Sub fw()
' FW formats graphics object to have a user selected width and
' a height that preserves the original width to height ratio.
' Revised 3/19/01.
tmw0 = InputBox("Input desired width in inches." & _
vbCr & "Height will remain proportional to selected width.", _
"Format Size of Object", "3")
tmw = 72 * tmw0
Selection.InlineShapes(1).LockAspectRatio = msoTrue
Selection.InlineShapes(1).Height = _
Selection.InlineShapes(1).Height * (tmw / Selection.InlineShapes(1).Width)
Selection.InlineShapes(1).Width = tmw
End Sub
'======
Sub GetEditMacs()
'
' GetEditMacs Macro
' Copy Edit.dot macros to current document
'
Application.DisplayAutoCompleteTips = True
NormalTemplate.AutoTextEntries("Filename and path").Insert Where:= _
Selection.Range, RichText:=True
Selection.MoveLeft Unit:=wdWord, Count:=1
Selection.Fields.Unlink
docloc$ = Selection.Text
Selection.Delete Unit:=wdCharacter, Count:=1
Application.OrganizerCopy Source:="E:\cm\templats\Edit.dot", _
Destination:=docloc$, Name:="EditMacs", Object:= _
wdOrganizerObjectProjectItems
End Sub
'======
Public Sub GoToBook(ByVal sss As String)
If Not ActiveDocument.Bookmarks.Exists(sss) Then
MsgBox ("GoToBook is attempting to find the bookmark: '" & sss & "'" & Chr(13) & _
"but this bookmark does not exist.")
End If
Selection.GoTo What:=wdGoToBookmark, Name:=sss
End Sub
'======
Sub GoToNu()
' GoTo Macro with input box.
' New GoTo function
'
Target = InputBox("Bookmark to Go To:", _
"Bookmark", "curr")
Selection.GoTo What:=wdGoToBookmark, Name:=Target
End Sub
'======
Sub h()
' h Macro
' Hides the selected text.
Selection.Style = ActiveDocument.styles("h,hidden")
End Sub
'======
Sub h2()
'
' h2 Macro
' Create an h2 style paragraph that starts with a sequence number.
'
Selection.Style = ActiveDocument.styles("Heading 2,h2,h2a")
Application.Run MacroName:="TP.my.ii"
Selection.TypeBackspace
Selection.TypeText Text:=". "
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="tmc"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
tmtitle = InputBox("Text for this item/section.", "Input Text", "text")
Selection.TypeText Text:=tmtitle