MacroWizard
12-14-2015, 04:14 PM
I am nearing the end of the project that I have been working on for quite some time. I figured that I would get some experts here to take a look at my code to make sure everything is in order. If someone could do me a favor and take a look, I would be willing to pay $30. I noticed that template image inserts sometimes produce an error 91. Sometimes they don't, though. I could really use your expertise.
I have three modules, Main, Macros, and RibbonControl.
Main:
Option Explicit
Dim oDoc As Document
Public lngInterval As Long
Sub GrabTemplate()
Dim aTemplate As Template
For Each aTemplate In Templates
If aTemplate.Name = "Compassion.dotm" Then
Set oTemplate = aTemplate
Exit For
End If
Next
End Sub
RibbonControl:
Option Explicit
Public myRibbon As IRibbonUI
Public oTemplate As Template
Public arrProcedures() As String
Dim i As Long
Sub OnLoad(ribbon As IRibbonUI)
'Create a ribbon instance
GrabTemplate
Set myRibbon = ribbon
On Error Resume Next
myRibbon.Invalidate
myRibbon.ActivateTab ("CustomTab1")
End Sub
'Callback for Button onAction
Sub MyBtnMacro(ByVal control As IRibbonControl)
'
' Tables and Parts Group
Select Case control.ID
Case Is = "Btn1"
Macros.NormalTable
Case Is = "Btn2"
Macros.ActionTable
Case Is = "Btn22"
Macros.TypeLines
Case Is = "Btn23"
Macros.LandscapePage
Case Is = "Btn24"
Macros.ObjectivesList
'
' Content Blocks Group
Case Is = "Btn3"
Macros.FacilitatorBlock
'
' Table of Contents Group
Case Is = "Btn6"
Macros.LessonMacro
Case Is = "Btn7"
Macros.Intro
Case Is = "Btn20"
Macros.Topic
Case Is = "Btn21"
Macros.Summary
'
' Couse Overview Group
Case Is = "Btn8"
Macros.FacilitatorGuide
Case Is = "Btn9"
Macros.ParticipantGuide
Case Is = "Btn25"
Macros.ParticipantGuide
Macros.PrintPG
Case Is = "Btn28"
Macros.FacilitatorGuide
Macros.PrintFG
'
' Images and Icons Groups
Case Is = "Btn11"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoActivity").Insert Selection.Range
Case Is = "Btn12"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoDiscussion").Insert Selection.Range
Case Is = "Btn13"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoHandout").Insert Selection.Range
Case Is = "Btn14"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoKeypoints").Insert Selection.Range
Case Is = "Btn15"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoDemon").Insert Selection.Range
Case Is = "Btn17"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoNewslide").Insert Selection.Range
Case Is = "Btn18"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoTransition").Insert Selection.Range
Case Is = "Btn16"
Macros.CreateTable
Case Is = "Btn19"
Macros.OpenUserGuide
Case Is = "Btn26"
Macros.OpenPPT
Case Is = "Btn27"
Macros.SendtoPowerpoint
Case Else
'Do nothing
End Select
lbl_Exit:
Exit Sub
End Sub
Sub GalleryOnAction(control As IRibbonControl, selectedID As String, selectedIndex As Integer)
Dim pCall As String
If Documents.Count = 0 Then
MsgBox "This control is disabled when there is no active document."
Exit Sub
End If
Select Case control.ID
Case "Grp1Gallery3"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("Signatures"). _
BuildingBlocks(selectedIndex + 1).Insert Selection.Range
Case Else
'Do nothing
End Select
End Sub
Macros:
Option Explicit
Sub SendtoPowerpoint()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
' Powerpoint Set Variables
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewNormal
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'**********************
'The Magic happens here
'**********************
Selection.Copy
PPApp.CommandBars.ExecuteMso "PasteDestinationTheme"
' Save the presentation
PPPres.Save
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
Sub LessonMacro()
'
' HeadingMacro Macro
' Create a new page after the current page. The new page will contain a heading. The new heading will appear in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
'
'Type the page content'
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.Style = ActiveDocument.Styles("FG Header 1")
Selection.Font.Name = "Arial"
Selection.Font.Size = 24
Selection.TypeText Text:="Lesson X: XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Pre-Lesson Preparation"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Lesson Description: "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Lesson Objectives: "
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Key Terms: "
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Materials Needed: "
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Lesson Duration: "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="XX Minutes"
' new line macro
Selection.TypeParagraph
Selection.TypeText Text:=" "
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("No Spacing")
Selection.Font.Name = "Arial"
'add form fields
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=10, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = "Time"
Selection.ParentContentControl.Tag = "Time"
Selection.MoveLeft Unit:=wdCharacter, Count:=91
Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = "Description"
Selection.ParentContentControl.Tag = "Description"
Selection.MoveLeft Unit:=wdCharacter, Count:=46
Selection.MoveLeft Unit:=wdCharacter, Count:=15, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = "Module"
Selection.ParentContentControl.Tag = "Module"
' goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
'add highlights to sections
Selection.MoveLeft Unit:=wdCharacter, Count:=11
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=3
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveLeft Unit:=wdCharacter, Count:=88
Selection.MoveLeft Unit:=wdCharacter, Count:=5, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=3
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveLeft Unit:=wdCharacter, Count:=43
Selection.MoveLeft Unit:=wdCharacter, Count:=5, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
'goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
'add bullets
Selection.MoveLeft Unit:=wdCharacter, Count:=32
Selection.MoveLeft Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Paragraphs(1).SelectNumber
Selection.MoveLeft Unit:=wdCharacter, Count:=20
Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Paragraphs(1).SelectNumber
Selection.MoveLeft Unit:=wdCharacter, Count:=13
Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.MoveLeft Unit:=wdCharacter, Count:=1
'goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.TypeText Text:=" "
'update the table of contents
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub PrintPG()
Dim oChoice As String
Dim oQuestion As String
Dim oSTR As String
Dim oCN As Variant
oCN = ActiveDocument.BuiltInDocumentProperties("Number of Pages") & ""
oSTR = "1,4,8-" & oCN & ""
oQuestion = "Would you like to turn off highlights for this operation?"
oChoice = MsgBox(oQuestion, vbYesNo, "Toggle Highlights")
If oChoice = vbNo Then
ActiveWindow.View.ShowHighlight = True
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
Else
ActiveWindow.View.ShowHighlight = False
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
End If
End Sub
Sub PrintFG()
Dim oChoice As String
Dim oQuestion As String
Dim oSTR As String
Dim oCN As Variant
oCN = ActiveDocument.BuiltInDocumentProperties("Number of Pages") & ""
oSTR = "1-" & oCN & ""
oQuestion = "Would you like to turn off highlights for this operation?"
oChoice = MsgBox(oQuestion, vbYesNo, "Toggle Highlights")
If oChoice = vbNo Then
ActiveWindow.View.ShowHighlight = True
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
Else
ActiveWindow.View.ShowHighlight = False
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
End If
End Sub
Sub ObjectivesList()
'
' ObjectivesList Macro
'
'
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="After completing this lesson, you will be able to:"
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
End Sub
Sub TypeLines()
'
' TypeLines Macro
'
'
Dim oNum As Variant
Dim i As Variant
oNum = InputBox("How many note lines would you like to insert into the table?")
For i = 1 To oNum
Selection.TypeText Text:= _
"___________________________________________________________"
Selection.TypeParagraph
Next i
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub LandscapePage()
Dim oDoc As Document
Dim i As Variant
Set oDoc = ActiveDocument
'goto end of current page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
' create a landscape page
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.TypeParagraph
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
With Selection.PageSetup
.Orientation = wdOrientLandscape
.SectionStart = wdSectionNewPage
End With
Selection.InsertBreak Type:=wdSectionBreakContinuous
Selection.GoToNext wdGoToPage
With Selection.PageSetup
.Orientation = wdOrientPortrait
.SectionStart = wdSectionNewPage
End With
For i = 6 To oDoc.Sections.Count
oDoc.Sections(i).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberin gAtSection = False
Next i
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub OpenPPT()
'This opens powerpoint
'
Dim oCC As Shape
For Each oCC In ActiveDocument.Shapes
If oCC.Title = "pptDisaster" Then
oCC.TextFrame.TextRange.InlineShapes(1).OLEFormat.DoVerb VerbIndex:=1
Else
' Do Nothing
End If
Next oCC
End Sub
Sub OpenUserGuide()
'This opens the user guide for viewing.
'
Dim oCC As Shape
For Each oCC In ActiveDocument.Shapes
If oCC.Title = "objguide" Then
oCC.TextFrame.TextRange.InlineShapes(1).OLEFormat.Open
Else
' Do Nothing
End If
Next
End Sub
Sub Intro()
'
' Intro Macro
' This creates a subheading. This subheading will show up in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Introduction"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:=" "
'goto bottom of the page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub Topic()
'
' Intro Macro
' This creates a subheading. This subheading will show up in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Topic"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:=" "
'goto bottom of the page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub Summary()
'
' Intro Macro
' This creates a subheading. This subheading will show up in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Summary"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:=" "
'goto bottom of the page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub NormalTable()
'
' NormalTable Macro
' Insert a normal table on the current page.
'
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="[Insert Slide]"
Selection.SelectColumn
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(6)
Selection.Collapse Direction:=wdCollapseStart
Selection.Move Unit:=wdColumn, Count:=-1
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(1)
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="[Insert Slide]"
Selection.SelectColumn
Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Tables(1).Select
Selection.Tables(1).Rows.WrapAroundText = True
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
Selection.TypeParagraph
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub ActionTable()
'
' ActionTable Macro
' Insert an Action Table on the currect page.
'
Selection.TypeParagraph
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=7, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="[Insert Slide]"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="[Insert Slide]"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderHorizontal)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(1)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(6)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Tables(1).Select
Selection.Tables(1).AutoFitBehavior (wdAutoFitFixed)
Selection.Tables(1).AutoFitBehavior (wdAutoFitFixed)
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603923969
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveUp Unit:=wdLine, Count:=3
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(0.5)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(5.5)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="Step"
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="Action"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="1"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="2"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="3"
Selection.MoveRight Unit:=wdCell
Selection.Tables(1).Select
Selection.Tables(1).Rows.WrapAroundText = True
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
'begin typing action table title etc
Selection.MoveLeft Unit:=wdCharacter, Count:=6
Selection.Tables(1).Cell(2, 2).Select
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Activity Title"
Selection.TypeParagraph
Selection.TypeText Text:="Activity type: "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="In this activity, you will..."
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Allow # minutes for this activity."
'highlight new text
Selection.MoveLeft Unit:=wdCharacter, Count:=27
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=8
Selection.MoveLeft Unit:=wdCharacter, Count:=3, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=28
Selection.MoveLeft Unit:=wdCharacter, Count:=14, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=3
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=14, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveRight Unit:=wdCharacter, Count:=1
'insert combobox for activity
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=13, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlComboBox)
Selection.ParentContentControl.Title = "tabactivity"
Selection.ParentContentControl.Tag = "tabactivity"
Selection.ParentContentControl.DropdownListEntries.Clear
Selection.ParentContentControl.DropdownListEntries.Add Text:=" ", Value:= _
" "
Selection.ParentContentControl.DropdownListEntries.Add Text:= _
"Mandatory Activity", Value:="Mandatory Activity"
Selection.ParentContentControl.DropdownListEntries.Add Text:= _
"Recommended Activity", Value:="Recommended Activity"
Selection.ParentContentControl.DropdownListEntries.Add Text:= _
"Recommended Questions", Value:="Recommended Questions"
Selection.MoveRight Unit:=wdCharacter, Count:=3
'goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
Selection.TypeParagraph
'error handling
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub FacilitatorBlock()
'
' FacilitatorBlock Macro
'
'
If Selection.Type <> wdSelectionIP Then
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.ParentContentControl.Title = "FacilitatorBlock"
Selection.ParentContentControl.Tag = "FacilitatorBlock"
Else
MsgBox "First select content to be placed within the facilitator block, then click the Facilitator Block button again.", vbInformation, "Error: No Content Selected"
End If
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub RegularBlock()
'
' RegularBlock Macro
'
'
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.TypeText Text:="Regular Block (Replace)"
Selection.ParentContentControl.Title = "RegularBlock"
Selection.ParentContentControl.Tag = "RegularBlock"
End Sub
Sub ParticipantGuide()
Dim ctl As ContentControl
For Each ctl In ActiveDocument.ContentControls
If ctl.Tag = "FacilitatorBlock" Then
ctl.Range.Font.Hidden = True
Else
' do nothing
End If
Next
With ActiveDocument
.ActiveWindow.View.ShowAll = False 'Hide all formatting marks
.ActiveWindow.View.ShowHiddenText = False 'Do not display hidden text
.Application.Options.PrintHiddenText = False 'Do not print hidden text
End With
Dim bmRange As Range
Set bmRange = ActiveDocument.Bookmarks("FacGuide").Range
bmRange.Text = "Participant Guide"
ActiveDocument.Bookmarks.Add _
Name:="FacGuide", _
Range:=bmRange
Dim hdrftrObject As HeaderFooter
Dim secObject As Section
Dim fldObject As Field
Dim rngHeadersFooters As Range
ActiveDocument.Fields.Update
For Each secObject In ActiveDocument.Sections
For Each hdrftrObject In secObject.Headers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
For Each hdrftrObject In secObject.Footers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
Next
End Sub
Sub FacilitatorGuide()
Dim ctl As ContentControl
For Each ctl In ActiveDocument.ContentControls
If ctl.Tag = "FacilitatorBlock" Then
ctl.Range.Font.Hidden = False
Else
' do nothing
End If
Next
With ActiveDocument
.ActiveWindow.View.ShowAll = False 'Hide all formatting marks
.ActiveWindow.View.ShowHiddenText = True 'Do not display hidden text
.Application.Options.PrintHiddenText = True 'Do not print hidden text
End With
Dim bmRange As Range
Set bmRange = ActiveDocument.Bookmarks("FacGuide").Range
bmRange.Text = "Facilitator Guide"
ActiveDocument.Bookmarks.Add _
Name:="FacGuide", _
Range:=bmRange
Dim hdrftrObject As HeaderFooter
Dim secObject As Section
Dim fldObject As Field
Dim rngHeadersFooters As Range
ActiveDocument.Fields.Update
For Each secObject In ActiveDocument.Sections
For Each hdrftrObject In secObject.Headers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
For Each hdrftrObject In secObject.Footers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
Next
End Sub
Sub CreateTable()
Dim oTbl As Table
Dim oCC As ContentControl
Dim oColType_T As New Collection, oColType_M As New Collection, oColType_D As New Collection
Dim lngIndex As Long
'Alternate method.
'Loop through the tables to select and delete the table with the ID called tblset
For Each oTbl In ActiveDocument.Tables
If oTbl.Title = "tblset" Then
oTbl.Delete
Exit For
End If
Next oTbl
'On Error GoTo Err_Interference - Repeated below. You don't need it here.
'Loop through the document once and collect the CCs of interest.
For Each oCC In ActiveDocument.ContentControls
Select Case oCC.Tag
Case "Time": oColType_T.Add oCC
Case "Module": oColType_M.Add oCC
Case "Description": oColType_D.Add oCC
End Select
Next oCC
'Define and format the table.
On Error GoTo Err_Interference
'Note will error if the last thing in the document is a CC (so would your previous method)
Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.SelectContentControlsByTitl e("crsOverview").Item(1).Range.Characters.Last.Next.Next.Next, NumRows:=oColType_M.Count + 1, NumColumns:=3)
On Error GoTo 0
With oTbl
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).Width = 15
.Columns(2).Width = 20
.Columns(3).Width = 65
.AutoFitBehavior (wdAutoFitWindow)
.Title = "tblset"
.Borders.InsideLineStyle = wdLineStyleSingle
.Borders.OutsideLineStyle = wdLineStyleSingle
With .Rows(1)
.Cells(1).Range.Text = "Time"
.Cells(2).Range.Text = "Module"
.Cells(3).Range.Text = "Description"
.Shading.BackgroundPatternColor = wdColorGray10
End With
'Put the CC data in the table.
For lngIndex = 1 To oColType_T.Count
.Cell(lngIndex + 1, 1).Range.Text = oColType_T.Item(lngIndex).Range.Text
.Cell(lngIndex + 1, 2).Range.Text = oColType_M.Item(lngIndex).Range.Text
.Cell(lngIndex + 1, 3).Range.Text = oColType_D.Item(lngIndex).Range.Text
Next lngIndex
End With
Selection.TypeParagraph
lbl_Exit:
Exit Sub
Err_Interference:
ActiveDocument.Range.InsertAfter ActiveDocument.ContentControls("crsOverview")
Resume
Stop
End Sub
Thank you in advance for your assistance. Also, anyone interested in taking this on, PM me your paypal information
I have three modules, Main, Macros, and RibbonControl.
Main:
Option Explicit
Dim oDoc As Document
Public lngInterval As Long
Sub GrabTemplate()
Dim aTemplate As Template
For Each aTemplate In Templates
If aTemplate.Name = "Compassion.dotm" Then
Set oTemplate = aTemplate
Exit For
End If
Next
End Sub
RibbonControl:
Option Explicit
Public myRibbon As IRibbonUI
Public oTemplate As Template
Public arrProcedures() As String
Dim i As Long
Sub OnLoad(ribbon As IRibbonUI)
'Create a ribbon instance
GrabTemplate
Set myRibbon = ribbon
On Error Resume Next
myRibbon.Invalidate
myRibbon.ActivateTab ("CustomTab1")
End Sub
'Callback for Button onAction
Sub MyBtnMacro(ByVal control As IRibbonControl)
'
' Tables and Parts Group
Select Case control.ID
Case Is = "Btn1"
Macros.NormalTable
Case Is = "Btn2"
Macros.ActionTable
Case Is = "Btn22"
Macros.TypeLines
Case Is = "Btn23"
Macros.LandscapePage
Case Is = "Btn24"
Macros.ObjectivesList
'
' Content Blocks Group
Case Is = "Btn3"
Macros.FacilitatorBlock
'
' Table of Contents Group
Case Is = "Btn6"
Macros.LessonMacro
Case Is = "Btn7"
Macros.Intro
Case Is = "Btn20"
Macros.Topic
Case Is = "Btn21"
Macros.Summary
'
' Couse Overview Group
Case Is = "Btn8"
Macros.FacilitatorGuide
Case Is = "Btn9"
Macros.ParticipantGuide
Case Is = "Btn25"
Macros.ParticipantGuide
Macros.PrintPG
Case Is = "Btn28"
Macros.FacilitatorGuide
Macros.PrintFG
'
' Images and Icons Groups
Case Is = "Btn11"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoActivity").Insert Selection.Range
Case Is = "Btn12"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoDiscussion").Insert Selection.Range
Case Is = "Btn13"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoHandout").Insert Selection.Range
Case Is = "Btn14"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoKeypoints").Insert Selection.Range
Case Is = "Btn15"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoDemon").Insert Selection.Range
Case Is = "Btn17"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoNewslide").Insert Selection.Range
Case Is = "Btn18"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("ICONS"). _
BuildingBlocks("icoTransition").Insert Selection.Range
Case Is = "Btn16"
Macros.CreateTable
Case Is = "Btn19"
Macros.OpenUserGuide
Case Is = "Btn26"
Macros.OpenPPT
Case Is = "Btn27"
Macros.SendtoPowerpoint
Case Else
'Do nothing
End Select
lbl_Exit:
Exit Sub
End Sub
Sub GalleryOnAction(control As IRibbonControl, selectedID As String, selectedIndex As Integer)
Dim pCall As String
If Documents.Count = 0 Then
MsgBox "This control is disabled when there is no active document."
Exit Sub
End If
Select Case control.ID
Case "Grp1Gallery3"
oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("Signatures"). _
BuildingBlocks(selectedIndex + 1).Insert Selection.Range
Case Else
'Do nothing
End Select
End Sub
Macros:
Option Explicit
Sub SendtoPowerpoint()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
' Powerpoint Set Variables
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewNormal
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'**********************
'The Magic happens here
'**********************
Selection.Copy
PPApp.CommandBars.ExecuteMso "PasteDestinationTheme"
' Save the presentation
PPPres.Save
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
Sub LessonMacro()
'
' HeadingMacro Macro
' Create a new page after the current page. The new page will contain a heading. The new heading will appear in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
'
'Type the page content'
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.Style = ActiveDocument.Styles("FG Header 1")
Selection.Font.Name = "Arial"
Selection.Font.Size = 24
Selection.TypeText Text:="Lesson X: XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Pre-Lesson Preparation"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Lesson Description: "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Lesson Objectives: "
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Key Terms: "
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Materials Needed: "
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Lesson Duration: "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="XX Minutes"
' new line macro
Selection.TypeParagraph
Selection.TypeText Text:=" "
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("No Spacing")
Selection.Font.Name = "Arial"
'add form fields
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=10, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = "Time"
Selection.ParentContentControl.Tag = "Time"
Selection.MoveLeft Unit:=wdCharacter, Count:=91
Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = "Description"
Selection.ParentContentControl.Tag = "Description"
Selection.MoveLeft Unit:=wdCharacter, Count:=46
Selection.MoveLeft Unit:=wdCharacter, Count:=15, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = "Module"
Selection.ParentContentControl.Tag = "Module"
' goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
'add highlights to sections
Selection.MoveLeft Unit:=wdCharacter, Count:=11
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=3
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveLeft Unit:=wdCharacter, Count:=88
Selection.MoveLeft Unit:=wdCharacter, Count:=5, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=3
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveLeft Unit:=wdCharacter, Count:=43
Selection.MoveLeft Unit:=wdCharacter, Count:=5, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
'goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
'add bullets
Selection.MoveLeft Unit:=wdCharacter, Count:=32
Selection.MoveLeft Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Paragraphs(1).SelectNumber
Selection.MoveLeft Unit:=wdCharacter, Count:=20
Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Paragraphs(1).SelectNumber
Selection.MoveLeft Unit:=wdCharacter, Count:=13
Selection.MoveLeft Unit:=wdCharacter, Count:=4, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.MoveLeft Unit:=wdCharacter, Count:=1
'goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.TypeText Text:=" "
'update the table of contents
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub PrintPG()
Dim oChoice As String
Dim oQuestion As String
Dim oSTR As String
Dim oCN As Variant
oCN = ActiveDocument.BuiltInDocumentProperties("Number of Pages") & ""
oSTR = "1,4,8-" & oCN & ""
oQuestion = "Would you like to turn off highlights for this operation?"
oChoice = MsgBox(oQuestion, vbYesNo, "Toggle Highlights")
If oChoice = vbNo Then
ActiveWindow.View.ShowHighlight = True
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
Else
ActiveWindow.View.ShowHighlight = False
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
End If
End Sub
Sub PrintFG()
Dim oChoice As String
Dim oQuestion As String
Dim oSTR As String
Dim oCN As Variant
oCN = ActiveDocument.BuiltInDocumentProperties("Number of Pages") & ""
oSTR = "1-" & oCN & ""
oQuestion = "Would you like to turn off highlights for this operation?"
oChoice = MsgBox(oQuestion, vbYesNo, "Toggle Highlights")
If oChoice = vbNo Then
ActiveWindow.View.ShowHighlight = True
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
Else
ActiveWindow.View.ShowHighlight = False
Application.ScreenRefresh
With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = oSTR
.Show
End With
End If
End Sub
Sub ObjectivesList()
'
' ObjectivesList Macro
'
'
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="After completing this lesson, you will be able to:"
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("FG Bullets")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="XXXX"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
End Sub
Sub TypeLines()
'
' TypeLines Macro
'
'
Dim oNum As Variant
Dim i As Variant
oNum = InputBox("How many note lines would you like to insert into the table?")
For i = 1 To oNum
Selection.TypeText Text:= _
"___________________________________________________________"
Selection.TypeParagraph
Next i
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub LandscapePage()
Dim oDoc As Document
Dim i As Variant
Set oDoc = ActiveDocument
'goto end of current page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
' create a landscape page
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.TypeParagraph
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
With Selection.PageSetup
.Orientation = wdOrientLandscape
.SectionStart = wdSectionNewPage
End With
Selection.InsertBreak Type:=wdSectionBreakContinuous
Selection.GoToNext wdGoToPage
With Selection.PageSetup
.Orientation = wdOrientPortrait
.SectionStart = wdSectionNewPage
End With
For i = 6 To oDoc.Sections.Count
oDoc.Sections(i).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberin gAtSection = False
Next i
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub OpenPPT()
'This opens powerpoint
'
Dim oCC As Shape
For Each oCC In ActiveDocument.Shapes
If oCC.Title = "pptDisaster" Then
oCC.TextFrame.TextRange.InlineShapes(1).OLEFormat.DoVerb VerbIndex:=1
Else
' Do Nothing
End If
Next oCC
End Sub
Sub OpenUserGuide()
'This opens the user guide for viewing.
'
Dim oCC As Shape
For Each oCC In ActiveDocument.Shapes
If oCC.Title = "objguide" Then
oCC.TextFrame.TextRange.InlineShapes(1).OLEFormat.Open
Else
' Do Nothing
End If
Next
End Sub
Sub Intro()
'
' Intro Macro
' This creates a subheading. This subheading will show up in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Introduction"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:=" "
'goto bottom of the page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub Topic()
'
' Intro Macro
' This creates a subheading. This subheading will show up in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Topic"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:=" "
'goto bottom of the page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub Summary()
'
' Intro Macro
' This creates a subheading. This subheading will show up in the table of contents.
'
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
Selection.InsertNewPage
Else
Selection.EndKey Unit:=wdStory
Selection.InsertNewPage
End If
Selection.Style = ActiveDocument.Styles("FG Header 2")
Selection.Font.Name = "Arial"
Selection.Font.Size = 20
Selection.TypeText Text:="Summary"
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:=" "
'goto bottom of the page
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Selection.MoveLeft
ActiveDocument.TablesOfContents(1).Update
End Sub
Sub NormalTable()
'
' NormalTable Macro
' Insert a normal table on the current page.
'
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.TypeText Text:="[Insert Slide]"
Selection.SelectColumn
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(6)
Selection.Collapse Direction:=wdCollapseStart
Selection.Move Unit:=wdColumn, Count:=-1
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(1)
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="[Insert Slide]"
Selection.SelectColumn
Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Tables(1).Select
Selection.Tables(1).Rows.WrapAroundText = True
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
Selection.TypeParagraph
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub ActionTable()
'
' ActionTable Macro
' Insert an Action Table on the currect page.
'
Selection.TypeParagraph
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=7, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="[Insert Slide]"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="[Insert Slide]"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
With Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderHorizontal)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(1)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(6)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Tables(1).Select
Selection.Tables(1).AutoFitBehavior (wdAutoFitFixed)
Selection.Tables(1).AutoFitBehavior (wdAutoFitFixed)
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603923969
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.SelectCell
Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=True
Selection.MoveRight Unit:=wdCell
Selection.MoveUp Unit:=wdLine, Count:=3
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(0.5)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
Selection.Columns.PreferredWidth = InchesToPoints(5.5)
Selection.Move Unit:=wdColumn, Count:=1
Selection.SelectColumn
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="Step"
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="Action"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="1"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="2"
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.TypeText Text:="3"
Selection.MoveRight Unit:=wdCell
Selection.Tables(1).Select
Selection.Tables(1).Rows.WrapAroundText = True
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
'begin typing action table title etc
Selection.MoveLeft Unit:=wdCharacter, Count:=6
Selection.Tables(1).Cell(2, 2).Select
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Activity Title"
Selection.TypeParagraph
Selection.TypeText Text:="Activity type: "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="In this activity, you will..."
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="Allow # minutes for this activity."
'highlight new text
Selection.MoveLeft Unit:=wdCharacter, Count:=27
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=8
Selection.MoveLeft Unit:=wdCharacter, Count:=3, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=28
Selection.MoveLeft Unit:=wdCharacter, Count:=14, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveLeft Unit:=wdCharacter, Count:=3
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=14, Extend:=wdExtend
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Selection.MoveRight Unit:=wdCharacter, Count:=1
'insert combobox for activity
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=13, Extend:=wdExtend
Selection.Range.ContentControls.Add (wdContentControlComboBox)
Selection.ParentContentControl.Title = "tabactivity"
Selection.ParentContentControl.Tag = "tabactivity"
Selection.ParentContentControl.DropdownListEntries.Clear
Selection.ParentContentControl.DropdownListEntries.Add Text:=" ", Value:= _
" "
Selection.ParentContentControl.DropdownListEntries.Add Text:= _
"Mandatory Activity", Value:="Mandatory Activity"
Selection.ParentContentControl.DropdownListEntries.Add Text:= _
"Recommended Activity", Value:="Recommended Activity"
Selection.ParentContentControl.DropdownListEntries.Add Text:= _
"Recommended Questions", Value:="Recommended Questions"
Selection.MoveRight Unit:=wdCharacter, Count:=3
'goto the bottom of the page
If Selection.Information(wdActiveEndPageNumber) < Selection.Information(wdNumberOfPagesInDocument) Then
Selection.GoToNext wdGoToPage
Selection.MoveLeft
Else
Selection.EndKey Unit:=wdStory
End If
Selection.TypeParagraph
'error handling
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub FacilitatorBlock()
'
' FacilitatorBlock Macro
'
'
If Selection.Type <> wdSelectionIP Then
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.ParentContentControl.Title = "FacilitatorBlock"
Selection.ParentContentControl.Tag = "FacilitatorBlock"
Else
MsgBox "First select content to be placed within the facilitator block, then click the Facilitator Block button again.", vbInformation, "Error: No Content Selected"
End If
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
End Sub
Sub RegularBlock()
'
' RegularBlock Macro
'
'
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.TypeText Text:="Regular Block (Replace)"
Selection.ParentContentControl.Title = "RegularBlock"
Selection.ParentContentControl.Tag = "RegularBlock"
End Sub
Sub ParticipantGuide()
Dim ctl As ContentControl
For Each ctl In ActiveDocument.ContentControls
If ctl.Tag = "FacilitatorBlock" Then
ctl.Range.Font.Hidden = True
Else
' do nothing
End If
Next
With ActiveDocument
.ActiveWindow.View.ShowAll = False 'Hide all formatting marks
.ActiveWindow.View.ShowHiddenText = False 'Do not display hidden text
.Application.Options.PrintHiddenText = False 'Do not print hidden text
End With
Dim bmRange As Range
Set bmRange = ActiveDocument.Bookmarks("FacGuide").Range
bmRange.Text = "Participant Guide"
ActiveDocument.Bookmarks.Add _
Name:="FacGuide", _
Range:=bmRange
Dim hdrftrObject As HeaderFooter
Dim secObject As Section
Dim fldObject As Field
Dim rngHeadersFooters As Range
ActiveDocument.Fields.Update
For Each secObject In ActiveDocument.Sections
For Each hdrftrObject In secObject.Headers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
For Each hdrftrObject In secObject.Footers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
Next
End Sub
Sub FacilitatorGuide()
Dim ctl As ContentControl
For Each ctl In ActiveDocument.ContentControls
If ctl.Tag = "FacilitatorBlock" Then
ctl.Range.Font.Hidden = False
Else
' do nothing
End If
Next
With ActiveDocument
.ActiveWindow.View.ShowAll = False 'Hide all formatting marks
.ActiveWindow.View.ShowHiddenText = True 'Do not display hidden text
.Application.Options.PrintHiddenText = True 'Do not print hidden text
End With
Dim bmRange As Range
Set bmRange = ActiveDocument.Bookmarks("FacGuide").Range
bmRange.Text = "Facilitator Guide"
ActiveDocument.Bookmarks.Add _
Name:="FacGuide", _
Range:=bmRange
Dim hdrftrObject As HeaderFooter
Dim secObject As Section
Dim fldObject As Field
Dim rngHeadersFooters As Range
ActiveDocument.Fields.Update
For Each secObject In ActiveDocument.Sections
For Each hdrftrObject In secObject.Headers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
For Each hdrftrObject In secObject.Footers
Set rngHeadersFooters = hdrftrObject.Range
For Each fldObject In rngHeadersFooters.Fields
fldObject.Update
Next fldObject
Next
Next
End Sub
Sub CreateTable()
Dim oTbl As Table
Dim oCC As ContentControl
Dim oColType_T As New Collection, oColType_M As New Collection, oColType_D As New Collection
Dim lngIndex As Long
'Alternate method.
'Loop through the tables to select and delete the table with the ID called tblset
For Each oTbl In ActiveDocument.Tables
If oTbl.Title = "tblset" Then
oTbl.Delete
Exit For
End If
Next oTbl
'On Error GoTo Err_Interference - Repeated below. You don't need it here.
'Loop through the document once and collect the CCs of interest.
For Each oCC In ActiveDocument.ContentControls
Select Case oCC.Tag
Case "Time": oColType_T.Add oCC
Case "Module": oColType_M.Add oCC
Case "Description": oColType_D.Add oCC
End Select
Next oCC
'Define and format the table.
On Error GoTo Err_Interference
'Note will error if the last thing in the document is a CC (so would your previous method)
Set oTbl = ActiveDocument.Tables.Add(Range:=ActiveDocument.SelectContentControlsByTitl e("crsOverview").Item(1).Range.Characters.Last.Next.Next.Next, NumRows:=oColType_M.Count + 1, NumColumns:=3)
On Error GoTo 0
With oTbl
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).Width = 15
.Columns(2).Width = 20
.Columns(3).Width = 65
.AutoFitBehavior (wdAutoFitWindow)
.Title = "tblset"
.Borders.InsideLineStyle = wdLineStyleSingle
.Borders.OutsideLineStyle = wdLineStyleSingle
With .Rows(1)
.Cells(1).Range.Text = "Time"
.Cells(2).Range.Text = "Module"
.Cells(3).Range.Text = "Description"
.Shading.BackgroundPatternColor = wdColorGray10
End With
'Put the CC data in the table.
For lngIndex = 1 To oColType_T.Count
.Cell(lngIndex + 1, 1).Range.Text = oColType_T.Item(lngIndex).Range.Text
.Cell(lngIndex + 1, 2).Range.Text = oColType_M.Item(lngIndex).Range.Text
.Cell(lngIndex + 1, 3).Range.Text = oColType_D.Item(lngIndex).Range.Text
Next lngIndex
End With
Selection.TypeParagraph
lbl_Exit:
Exit Sub
Err_Interference:
ActiveDocument.Range.InsertAfter ActiveDocument.ContentControls("crsOverview")
Resume
Stop
End Sub
Thank you in advance for your assistance. Also, anyone interested in taking this on, PM me your paypal information