VBA - Snippets

Cross_Insert

Public Function Cross_Insert(ByVal lRefNo As Long) As Boolean

   On Error GoTo ErrorHandler

   Selection.InsertCrossReference ReferenceType:=WdReferenceType.wdRefTypeNumberedItem, _
                                  ReferenceKind:=WdReferenceKind.wdNumberNoContext, _
                                  ReferenceItem:=lRefNo, _
                                  InsertAsHyperlink:=True, _
                                  IncludePosition:=False, _
                                  SeparateNumbers:=False, _
                                  SeparatorString:=" "
   Cross_Insert = True
   Exit Function
ErrorHandler:
   Call Message_CrossReferenceNoParagraph
   Cross_Insert = False
End Function

Cross_NoParagraph

Public Sub Message_CrossReferenceNoParagraph()
Dim sMessage As String
    sMessage = "There is no paragraph following this heading." & _
               vbCrLf & vbCrLf & _
               "Before a cross-reference to this heading can be inserted," & _
               vbCrLf & _
               "a paragraph return must be added after the heading."
    Call MsgBox(sMessage, vbOKOnly + vbInformation, g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Insert Cross Reference")
    Call Tracer_Add("MESSAGE", sMessage)
End Sub

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

References_BuildAll

Public Function References_BuildAll() 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

References_CheckThisIsAHeading

Public Function References_CheckThisIsAHeading( _
         ByVal sNumberedItem As String) _
         As Boolean

Const sPROCNAME As String = "References_CheckThisIsAHeading"

Dim ispace As Integer
Dim ichar As Integer
Dim sprefix As String

   On Error GoTo ErrorHandler

   ispace = InStr(sNumberedItem, " ")
   If (ispace > 0) Then
      sprefix = Left(sNumberedItem, ispace - 1)
      If Right(sprefix, 1) = "." Then
         ichar = InStr(sNumberedItem, ".A.") + InStr(sNumberedItem, ".P.") + InStr(sNumberedItem, ".S.")
         If ((ichar > 0) And (ispace > ichar)) Then
            References_CheckThisIsAHeading = True
         Else
            References_CheckThisIsAHeading = False
         End If
      Else
         If (Asc(sprefix) >= 97 And Asc(sprefix) <= 122) Then
            References_CheckThisIsAHeading = False
         Else
            References_CheckThisIsAHeading = True
         End If
      End If
   End If
   Exit Function
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
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