Please help me spot potential problems in my code.

**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.RestartNumberingAtSection = 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.SelectContentControlsByTitle("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

**gmaxey** · 12-15-2015, 08:27 AM

MW,

While your code probably works, it looks like a dog's breakfast. I don't know why you have the Main module and if the template you are after is the one containing your code just use Set oTemplate = ThisDocument.AttachedTemplate

For RibbonControl, as I've said before that isn't a good name and:

Select Case control.ID
Case "Btn1": Macros.NormalTable
Case "Btn2": Macros.ActionTable
Case "Btn22": Macros.TypeLines

might look better.

The rest ugh! No one is going to have your styles and I for one won't try to create them for $30. However, as Graham has advised, if you are going to be doing this sort of thing going forward you should look to ranges and not write code like you would type out the document. Rather than some of the rambling macros, why don't you define buildingblocks of all that formatted text and simply insert the building block?

**MacroWizard** · 12-15-2015, 09:14 AM

Greg,

Thanks for your assistance. I shall make a donation to your website this afternoon. I knew I was forgetting to set the variable. I renamed ribboncontrol to CompRibCont. The code definitely could use some cleanup. Unfortunately some of the inserted pieces are recorded macros. I think i'll work on cleaning it up and then post here once I've finished. As for the custom styles, they're just headers recognized by the table of contents, as you probably have deduced.

Thank you again, your help is always spot on and I appreciate being able to learn from someone with so much experience.

**gmaxey** · 12-15-2015, 09:44 AM

For example, using your ActionTable macro if you want, insert an Action Table in the template. Select it, ALT+F3 and save it as a building block. Then can all of that mash of code and replace it with:

Sub ActionTable()
ThisDocument.AttachedTemplate.BuildingBlockTypes(wdTypeAutoText).Categories ("General").BuildingBlocks("Action Table").Insert _
Where:=Selection.Range, RichText:=True
End Sub

**MacroWizard** · 12-15-2015, 10:40 AM

Greg,

I followed your advice and put everything that I can into quick parts galleries. Now I can spam buttons without errors. I am going to post my new code below and you'll be able to tell right away that it looks more like a dog's lunch than a dog's breakfast now. I think that's progress.

CompRibControl:

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)
Set oTemplate = ThisDocument.AttachedTemplate
Select Case control.ID
'
'View Group
    Case Is = "Btn8"
      Macros.FacilitatorGuide
    Case Is = "Btn9"
      Macros.ParticipantGuide
'
'Print Group
    Case Is = "Btn25"
      Macros.ParticipantGuide
      Macros.PrintPG
    Case Is = "Btn28"
      Macros.FacilitatorGuide
      Macros.PrintFG
'
'Tables and Parts Group
    Case Is = "Btn1"
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("TableTypes"). _
         BuildingBlocks("nTable").Insert Selection.Range
    Case Is = "Btn2"
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("TableTypes"). _
         BuildingBlocks("aTable").Insert Selection.Range
    Case Is = "Btn3"
      Macros.FacilitatorBlock
    Case Is = "Btn22"
      Macros.TypeLines
    Case Is = "Btn23"
      Macros.LandscapePage
    Case Is = "Btn24"
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("lessons"). _
         BuildingBlocks("objlist").Insert Selection.Range
'
' Table of Contents Group
    Case Is = "Btn6"
      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
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("lessons"). _
         BuildingBlocks("xLesson").Insert Selection.Range
'
    Case Is = "Btn7"
      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
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("lessons"). _
         BuildingBlocks("xIntro").Insert Selection.Range
'
    Case Is = "Btn20"
      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
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("lessons"). _
         BuildingBlocks("xTopic").Insert Selection.Range
'
    Case Is = "Btn21"
      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
       oTemplate.BuildingBlockTypes(wdTypeCustom1).Categories("lessons"). _
         BuildingBlocks("xSummary").Insert Selection.Range
'
' 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 = "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()
'This subroutine sends a selection to an active powerpoint presentation without the need for manual coping and pasting
'Create and set variables
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
'Open PowerPoint in normal view
PPApp.ActiveWindow.ViewType = ppViewNormal
'Reference the active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
        
'Copy from the document and paste on the active slide in destination formatting
Selection.Copy
PPApp.CommandBars.ExecuteMso "PasteDestinationTheme"
' Save the presentation
PPPres.Save
'Reset variables to nothing
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
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 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.RestartNumberingAtSection = False
  Next i
  
On Error GoTo lbl_Exit
lbl_Exit:
Exit Sub
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 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 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.SelectContentControlsByTitle("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

**gmaxey** · 12-15-2015, 01:32 PM

Case "Btn8": Macros.FacilitatorGuide
does the same thing as:
Case Is = "Btn8"
Macros.FacilitatorGuide

Here is my take on one of your procedures:

Sub PrintFG()
'None of this is pointing out a problemd. Just making observations.
'Your variable naming doesn't make much sense.  When using camelBack notation, "o" typically indicates an object.
'Here is how I would name your variables
Dim strChoice As String, strQuestion As String
Dim strPageRange As String
Dim varBIDP
'But it seems you don't really need any of them.
  If MsgBox("Would you like to turn off highligts for this operation?", vbQuestion + vbYesNo, "Toggle Highlights") = vbYes Then
    ActiveWindow.View.ShowHighlight = True
  Else
    ActiveWindow.View.ShowHighlight = False
  End If
  Application.ScreenRefresh
  With Dialogs(wdDialogFilePrint)
    .Range = wdPrintRangeOfPages
    .Pages = "1-" & ActiveDocument.BuiltInDocumentProperties("Number of Pages") & ""
    .Show
  End With
End Sub

**gmaxey** · 12-16-2015, 05:00 PM

Your planned donation yesterday afternoon never materialized.

**MacroWizard** · 12-16-2015, 07:46 PM

Got paid today. Thanks again.

**gert.thys** · 12-22-2015, 12:44 PM

Thread: Please help me spot potential problems in my code.

Thread Tools

Display

Please help me spot potential problems in my code.

Posting Permissions