VBA Snippets

Bold

Bolds the selected cells.

Public Function Sel_Bold(Optional bBold As Boolean = True) As Boolean
Const sPROCNAME As String = "Sel_Bold"
   On Error GoTo AnError
   Selection.Font.Bold = bBold
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "bold / unbold the highlighted cells")
End Function

BoldIsIt

Determines if any of the selected cells contain bold text.

Public Function Sel_BoldIsIt() As Boolean
Const sPROCNAME As String = "Sel_BoldIsIt"
   On Error GoTo AnError
   If Selection.Font.Bold = True Then Sel_BoldIsIt = True
   If Selection.Font.Bold = False Then Sel_BoldIsIt = False
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if any of the highlighted cells are bold or unbold")
End Function

FindReplace

Performs a find and replace on the current selection in the active table.

Public Sub Text_FindReplace(sFindText As String, _
                            sReplaceText As String)
   On Error GoTo AnError
   
   With Selection.Find
     .Replacement.ClearFormatting
     .Text = sFindText
     .Replacement.Text = sReplaceText
     .Execute Replace:=wdReplaceAll
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_FindReplace", msMODULENAME, 1, _
        "")
End Sub

Format

Applies formatting to the current selection.

Public Sub Sel_Format()
Const sPROCNAME As String = "Sel_Format"
   On Error GoTo AnError

'italics, underline, font name, font size

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "apply any formatting to the current selection")
End Sub

Format

Formats the text that is currently selected.

Public Sub Text_Format(sFontName As String, _
                       sngFontSize As Single, _
                       lFontColour As Long, _
                       bBold As Boolean)
   On Error GoTo AnError
   Selection.style = ActiveDocument.Styles("Normal")
   With Selection.Font
      .Name = Return_FontName(sFontName)
      .Size = sngFontSize
      .Italic = False
      .Bold = bBold
      .ColorIndex = lFontColour
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_Format", msMODULENAME, 1, _
        "")
End Sub

HasAnyShapes

Public Function Sel_HasAnyShapes() As Boolean
   On Error GoTo AnError
   If Application.Selection.Range.ShapeRange.Count > 0 Then
      Sel_HasAnyShapes = True
   End If
AnError:
   Sel_HasAnyShapes = False
End Function

MoveAbove

Moves a particular number of lines above the current selection.

Public Sub Text_MoveAbove(iNoOfLines As Integer)
   On Error GoTo AnError

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

MoveDown

Moves a particular number of lines below the current selection.

Public Sub Text_MoveDown(iNoOfLines As Integer)
   On Error GoTo AnError
                                                     
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Text_MoveDown", msMODULENAME, 1, _
        "")
End Sub

PasteSpecial

Public Function Sel_PasteSpecial(ByVal enPasteDataType As WdPasteDataType, _
                                 ByVal bLink As Boolean, _
                        Optional ByVal bInformUser As Boolean = True) _
                                 As Boolean
   
   On Error GoTo AnError
      
   Selection.Range.PasteSpecial Placement:=wdInLine, DataType:=enPasteDataType, Link:=bLink
   Sel_PasteSpecial = True
   Exit Function
   
AnError:
   If bInformUser = True Then
      Call MsgBox("There is nothing on the Clipboard to paste.", vbCritical)
   End If
   Sel_PasteSpecial = False
End Function

RemoveLastChar

Removes the last character if it matching a given string from all the cells currently highlighted.

Public Sub Sel_RemoveLastChar(Optional sChar As String = "%")
Const sPROCNAME As String = "Sel_RemoveLastChar"
Dim scontents As String, clcell As cell
   On Error GoTo AnError
   For Each clcell In Selection.Cells
      scontents = Left$(clcell.Range.Text, Len(clcell.Range.Text) - 2)
      If Len(scontents) > 0 Then
         If Right$(scontents, 1) = sChar Then _
            clcell.Range.Text = Left$(scontents, Len(scontents) - 1) & vbCrLf
      End If
   Next clcell
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the last character if it matches """ & sChar & """" & _
        " from all the cells currently highlighted")
End Sub

RemovePreceedingChar

Removes all the given characters that preceed any text in the cells of the current selection.

Public Sub Sel_RemovePreceedingChar(Optional sChar As String = " ")
Const sPROCNAME As String = "Sel_RemoveLastChar"
Dim scontents$, clcell As cell
   On Error GoTo AnError
   For Each clcell In Selection.Cells
      scontents = Left$(clcell.Range.Text, Len(clcell.Range.Text) - 2)
      Do While Left$(scontents, 1) = sChar
         scontents = Right$(scontents, Len(scontents) - 1)
      Loop
      clcell.Range.Text = scontents & Right$(clcell.Range.Text, 1)
   Next clcell
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove all the characters that preceed a given string " & _
        "from all the cells currently highlighted")
End Sub

TitleCase

Public Sub Selection_TitleCase()
Const sPROCNAME As String = "Selection_TitleCase"
Dim lclist As String
Dim wrd As Integer
Dim sTest As String
   On Error GoTo ErrorHandler
   ' list of lowercase words, surrounded by spaces
   lclist = " of the by to this is from a "
   Selection.Range.Case = wdTitleWord
   For wrd = 2 To Selection.Range.Words.Count
       sTest = Trim(Selection.Range.Words(wrd))
       sTest = " " & LCase(sTest) & " "
       If InStr(lclist, sTest) Then
           Selection.Range.Words(wrd).Case = wdLowerCase
       End If
   Next wrd
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

UnderlinedIsIt

Determines if any of the highlighted cells are underlined.

Public Function Sel_UnderlinedIsIt() As Boolean
Const sPROCNAME As String = "Sel_UnderlinedIsIt"
   On Error GoTo AnError
   Sel_AnyUnderlined = _
     (Selection.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle)
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if any of the highlighted cells are underlined")
End Function