VBA Snippets

Bookmark_Delete

Deletes a bookmark from the active document.

Public Sub Bookmark_Delete(ByVal sBookmarkName As String)
   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Bookmark_Delete", msMODULENAME, 1, _
        "delete the bookmark """ & sBookmarkName & """")
End Sub

Bookmark_Exists

Public Function Bookmark_Exists(ByVal sBookmarkName As String, _
                                ByVal bDisplayMessage As Boolean) As Boolean
Const sPROCNAME As String = "Bookmark_Exists"
Dim breturn As Boolean

   On Error GoTo ErrorHandler
   
   breturn = False
   breturn = ActiveDocument.Bookmarks.Exists(sBookmarkName)
   If (breturn = False) Then
      If (bDisplayMessage = True) Then
         Call modMessages.Message_BookmarkDoesNotExists(sBookmarkName)
      End If
   End If
   Bookmark_Exists = breturn
   
   Exit Function

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

Bookmark_GoTo

Goes to a particular bookmark in the current document.

Public Sub Bookmark_GoTo(ByVal sBookmarkName As String)
   On Error GoTo AnError

   Application.GoTo Reference:=sBookMarkName

   Selection.GoTo What:=wdGoToBookmark, Name:=sBookmarkName

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Bookmark_GoTo", msMODULENAME, 1, _
        "go to the bookmark """ & sBookmarkName & """")
End Sub

Bookmark_Insert

Inserts a bookmark at the current position in the active document.

Public Sub Bookmark_Insert(ByVal sBookmarkName As String)
   On Error GoTo AnError
   
'   With ActiveDocument.Bookmarks
'           .Add Range:=Selection.Range, Name:=sBookMarkName
'           .DefaultSorting = wdSortByName
'           .ShowHidden = False
'   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Bookmark_Insert", msMODULENAME, 1, _
        "insert the bookmark """ & sBookmarkName & """ at the current position")
End Sub

Bookmark_ParagraphSelect

Selects the paragraph that has the bookmark with the corresponding name at the front.

Public Sub Bookmark_ParagraphSelect(ByVal sBookMarkName As String)
   On Error Goto AnError
   With Selection
      .GoTo What:=wdGoToBookmark, Name:=sBookMarkName
      .StartOf wdParagraph
      .EndOf wdParagraph, wdExtend
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Bookmark_ParagraphSelect", msMODULENAME, 1, _
        "select the paragragh bookmark """ & sBookMarkName & """")
End Sub

Bookmark_RemoveUnwantedChars

Removes all the unwanted characters that are not allowed to appear in bookmarks.

Public Function Bookmark_RemoveUnwantedChars(ByVal sBookmarkName As String, _
                                    Optional ByVal sReplaceChar as String = "_") _
                                             As String
Dim sfinaltext As String
Dim icount As Integer

   On Error Goto AnError
   For icount = 1 To Len(sBookmarkName)
      If Mid(sBookmarkName, icount, 1) = " " Or _
         Mid(sBookmarkName, icount, 1) = "-" Then
         sfinaltext = sfinaltext & "_"
      Else
         sfinaltext = sfinaltext & Mid(sBookmarkName, icount, 1)
      End If
   Next icount
   Bookmark_RemoveUnwantedChars = sfinaltext

   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Bookmark_RemoveUnwantedChars", msMODULENAME, 1, _
        "remove all the unwanted characters that cannot appear in bookmarks")
End Function

Bookmark_TextAdd

Public Sub Bookmark_TextAdd(ByVal bCancel As Boolean, _
                            ByVal sBookmarkName As String, _
                            ByVal sText As String, _
                   Optional ByVal bExtend As Boolean = False)

   On Error GoTo AnError
   If (bCancel = False) And Bookmark_GoTo(sBookmarkName) = True Then

      If bExtend = True Then Selection.EndKey wdLine, wdExtend
      Selection.TypeText Text:=sText
   Else
      bCancel = True
   End If

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Bookmark_TextAdd", msMODULENAME, 1, _
        "add the text" & vbcrlf & """" & sText & """" & _
        "to the bookmark """ & sBookmarkName & """")
End Sub

Bookmarks_DeleteAll

Public Sub Bookmark_DeleteAll()
Dim ibookmarknumber As Integer
   On Error GoTo AnError
   For ibookmarknumber = 1 To ActiveDocument.Bookmarks.Count
      ActiveDocuments.Bookmarks(1).Delete
   Next ibookmarknumber

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Bookmark_DeleteAll", msMODULENAME, 1, _
        "remove all the bookmarks from the active document)
End Sub

Field_Delete

Removes a particular field from the active document.

Public Sub Field_Delete(sFieldName As String, _
                        sPropertyValue As String)
Const sPROCNAME As String = "Field_Delete"
   On Error GoTo AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

Field_Insert

Inserts a field at the current position in the active document.

Public Sub Field_Insert(sText As String, _
                        sStyleName As String)
Const sPROCNAME As String = "Field_Insert"
   On Error GoTo AnError
   Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
                                                Text:=sText, _
                                                Preserveformatting:=True
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "insert the field")
End Sub

Field_Trim

Trims a field removing any leading or trailing spaces.

Public Sub Field_Trim(sDisplayText As String, _
                      lFieldType As Long)
Const sPROCNAME As String = "Field_Trim"
Dim fldField As Field
   On Error GoTo AnError
   For Each fldField In ActiveDocument.Fields
      If fldField.Type = lFieldType And _
         InStr(1, fldField.Code, sDisplayText) > 0 Then
         fldField.Code.Text = Trim(CStr(fldField.Code))
      End If
   Next fldField
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "trim the added field and remove the extra space")
End Sub

Fields_UpdateAll

Updates all the fields in the active document, including all sections, headers and footers.

Public Sub Fields_UpdateAll()
Const sPROCNAME As String = "Fields_UpdateAll"
   On Error GoTo AnError
   Selection.WholeStory
   Selection.Fields.Update

   Call Section_FirstPageUpdate
   Call Section_CurrentPageUpdate
   Call Section_EvenPageUpdate
   Call Section_PrimaryPageUpdate
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "update ALL the fields in the active document")
End Sub

Hyperlink_Insert

Inserts a hyperlink at the current location.

Public Sub Doc_HyperlinkInsert()
   On Error GoTo AnError
' ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
'        SubAddress:="MyBookmark"
 
'to a bookmark in another document
' ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
'        "C:\MyDoc.doc", SubAddress:=""
 
'to a web address
' ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
'        "http://www.microsoft.com/office/", SubAddress:=""
  
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_HyperlinkInsert", msMODULENAME, 1, _
        "insert a hyperlink to " & ">>>>>>>>>>>>>>" & " at the current position")
End Sub

Links_BreakAll

Public Sub Links_BreakAll(ByVal bShapes As Boolean, _
                           ByVal bFields As Boolean, _
                           ByVal bFieldsDDE As Boolean)
Dim objShape As Shape
Dim objField As Field
   
   On Error GoTo AnError
   
   If bShapes = True Then
      For Each shapeLoop In ActiveDocument.Shapes
          With shapeLoop
             '.Select
              If .Type = MsoShapeType.msoLinkedOLEObject Then
                  .LinkFormat.Update
                  .LinkFormat.BreakLink
              End If
          End With
      Next shapeLoop
   End If
   
   If bFields = True Then
      For Each objField In ActiveDocument.Fields
         Debug.Print objField.Code.Text
         If objField.Type = wdFieldDDEAuto Then
            objField.Unlink
         End If
         'objField.LinkFormat.BreakLink
      Next objField
   End If
   
   Exit Sub
AnError:
   Call Error_Handle("Links_BreakAll", msMODULENAME, _
        "")
End Sub