VBA Snippets

Exists

Public Function References_CaptionExists(ByVal TestCaption As String) As Boolean

Const sPROCNAME As String = "References_CaptionExists"

   On Error GoTo ErrorHandler

   Dim oCaptionLabel As Word.CaptionLabel
   Dim blnFound As Boolean

   blnFound = False

   For Each oCaptionLabel In Application.CaptionLabels
      If oCaptionLabel.Name = TestCaption Then
         blnFound = True
      End If
   Next oCaptionLabel

   Table_CaptionExists = blnFound

   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Insert

Public Function References_CaptionInsert( _
         ByRef oDocument As Document, _
         ByVal sCaptionLabel As String, _
         ByVal sStyleName As String, _
Optional ByVal bDisplayBold As Boolean = False) _
         As Range
         
Const sPROCNAME As String = "References_CaptionInsert"
Dim lBoldStart As Long
Dim lBoldFinish As Long
Dim oBoldRange As Word.Range
   On Error GoTo ErrorHandler
   With Selection
       Set oBoldRange = Selection.Range
       lBoldStart = Selection.Start
       .InsertCaption Label:=sCaptionLabel, _
                      Position:=wdCaptionPositionBelow
       lBoldFinish = Selection.Start
       If (bDisplayBold = True) Then
          oBoldRange.SetRange Start:=lBoldStart, End:=lBoldFinish
          oBoldRange.Font.Bold = True
       End If
       .EndKey Unit:=wdLine
       .Font.Bold = False
   End With
   Set References_CaptionInsert = Selection.Range
   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
   Set References_CaptionInsert = Nothing
End Function

Public Function References_CaptionInsert(ByRef objDocument As Word.Document, _
                                         ByVal Format As String) As Word.Range
                                    
Const sPROCNAME As String = "References_CaptionInsert"

   On Error GoTo ErrorHandler

   If modReferences.References_CaptionExists(TABLE_CAPTION_TEXT) = False Then
'       Application.CaptionLabels.Add(Name:=TABLE_CAPTION_TEXT)
   End If

   'Then add the caption
   With Application.CaptionLabels(TABLE_CAPTION_TEXT)
       .NumberStyle = Word.WdCaptionNumberStyle.wdCaptionNumberStyleArabic
       .IncludeChapterNumber = False
   End With

   With Application.Selection
'       .InsertCaption(Label:=TABLE_CAPTION_TEXT, _
'                      TitleAutoText:="InsertCaption1", _
'                      Title:="", _
'                      Position:=Word.WdCaptionPosition.wdCaptionPositionBelow)
'
'       .Style = objDocument.Styles(Format)
'       .TypeText(Text:=": [Caption]")
'       .HomeKey(Unit:=Word.WdUnits.wdLine, Extend:=Word.WdMovementType.wdExtend)
'       .EndKey(Unit:=Word.WdUnits.wdLine)
   End With

   References_CaptionInsert = Application.Selection.Range

   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
   Set References_CaptionInsert = Nothing
End Function

Insert

Public Function References_SourceInsert( _
         ByRef oDocument As Document, _
         ByVal sSourceLabel As String, _
         ByVal sStyleName As String) As Range
         
Const sPROCNAME As String = "References_SourceInsert"
   On Error GoTo ErrorHandler
   With Selection
      .Style = sStyleName
      .TypeText text:=sSourceLabel
      .TypeText text:=" "
   End With
   Set References_SourceInsert = Selection.Range
   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
   Set References_SourceInsert = Nothing
End Function

Question_ReferenceBuilder

Public Function Question_ReferenceBuilder() As Boolean
Dim breturn As Boolean
Dim lResult As VBA.VbMsgBoxResult
Dim sMessage As String
    sMessage = "Are you sure you want to build all the references."
    lResult = MsgBox(sMessage, vbYesNo + vbQuestion, g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Reference Builder")
    If (lResult = vbYes) Then breturn = True
    If (lResult = vbNo) Then breturn = False
    Call Tracer_Add("QUESTION", sMessage)
    Question_ReferenceBuilder = breturn
End Function

TOCAdd

Adds a table of contents to the active document.

Public Sub Doc_TOCAdd()
   On Error GoTo AnError
'ActiveDocument.TablesOfContents.Add Range:=myRange, _
'    UseFields:=False, UseHeadingStyles:=True, LowerHeadingLevel:=3, _
'    UpperHeadingLevel:=1
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle("Doc_TOCAdd", msMODULENAME, 1, _
        "add a Table Of Contents to the document")
End Sub

TOCUpdate

Updates the table of contents in the active document.

Public Sub Doc_TOCUpdate(Optional bJustPageNumbers As Boolean = False, _
                         Optional sDocName As String = "")
Dim tocTableOfContents As TableOfContents
   On Error GoTo AnError
   If sDocName <> "" Then Documents(sDocumentName).Activate
   
   For Each tocTableOfContents In ActiveDocument.TablesOfContents
      If bJustPageNumbers = True Then tocTableOfContents.UpdatePageNumbers
      If bJustPageNumbers = False Then tocTableOfContents.Update
   Next tocTableOfContents

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_TOCUpdate", msMODULENAME, 1, _
        "update the Table Of Contents")
End Sub