VBA Snippets

ApplyStyle

Defines the style of the current paragraph.

Public Sub Para_ApplyStyle(sStyleName As String)
Const sPROCNAME As String = "Para_DefineStyle"
   On Error GoTo AnError
   Selection.Paragraphs.style = sStyleName
   If gbDEBUG = False Then Exit Sub

AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the style for the whole paragraph")
End Sub

Combine

Combines all the paragraphs in the active cell to one paragraph with an appropriate full stop and capital letter.

Public Sub Para_Combine(sSeperateChar As String, _
                        Optional bCapitalPrefix As Boolean = True, _
                        Optional bFullStop As Boolean = True)
Const sPROCNAME As String = "Para_Combine"
Dim icurrentrow As Integer, icurrentcol As Integer
Dim bTextFound As Boolean, bParaStart As Boolean, bCarriageRet As Boolean
Dim bMoreBullets As Boolean
   On Error GoTo AnError
   bMoreBullets = True
   bTextFound = False

   icurrentrow = Selection.Cells(1).RowIndex
   icurrentcol = Selection.Cells(1).ColumnIndex
                   
'while still in a table and still in the same row
   Do While bMoreBullets = True
'something other than a carriage return has been found
      If Selection.Characters(1).Text <> Chr(13) Then bTextFound = True
      
'removes any extra spaces from the beginning of the line
      Do While Asc(Selection.Characters(1).Text) = 32
         Selection.Characters(1).Delete
         Selection.MoveLeft wdCharacter
      Loop
'convert to a capital letter
      If bCapitalPrefix = True Then _
         Selection.Characters(1).Text = Str_CharCapital(Selection.Characters(1).Text)
                  
'move to the end of the paragraph
      Selection.MoveDown wdParagraph, 1, wdExtend
      Selection.MoveRight wdCharacter
      Selection.MoveLeft wdCharacter
      
'is there a carriage return at the end of the paragraph
      If Asc(Selection.Characters(1).Text) = 13 Then
                  
'no text was found so delete the carriage return to join up paragraphs
         If bTextFound = False Then Selection.Delete wdCharacter
                  
         If bTextFound = True Then
'removes any extra spaces from the end of the line
            Selection.MoveLeft wdCharacter, 1
            Do While Asc(Selection.Characters(1).Text) = 32
               Selection.Delete wdCharacter
               Selection.MoveLeft wdCharacter, 1
            Loop
            Selection.MoveRight wdCharacter, 1
            
'move the cursor to the next character in order to test for more text
            Selection.MoveRight wdCharacter, 1
'are there any more bullets / paragraphs to follow
            If Cell_CurrentlyIn(icurrentrow, icurrentcol) = True Then
               Selection.MoveLeft wdCharacter, 1
               Selection.Delete wdCharacter
            Else
               Selection.MoveLeft wdCharacter, 1
            End If

            Selection.MoveLeft wdCharacter, 1
            If Selection.Characters(1).Text = sSeperateChar Then
               Selection.MoveRight wdCharacter, 1
               If Asc(Selection.Characters(1).Text) <> 13 Then
'there is more text to follow so insert a space after the paragraph
                  Selection.TypeText Chr(32)
                  Selection.MoveLeft wdCharacter, 1
                  Selection.MoveRight wdCharacter, 1
               End If
            Else
               Selection.MoveRight wdCharacter, 1
               If bMoreBullets = True And sSeperateChar = Chr(46) Then _
                  Selection.TypeText sSeperateChar
   
               If Asc(Selection.Characters(1).Text) <> 13 Then
                  Selection.TypeText Chr(32)
               End If
            End If
            
'check if there are any more bullets
            Selection.MoveRight wdCharacter, 1
            If Cell_CurrentlyIn(icurrentrow, icurrentcol) = True Then
               bMoreBullets = True
            Else
               bMoreBullets = False
            End If
            Selection.MoveLeft wdCharacter, 1
         End If
      End If
   Loop
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Sub

FindBlueText

Public Function Para_FindBlueText(ByVal oParagraph As Word.Range) As Boolean
Const sPROCNAME As String = "Para_FindBlueText"
Dim oWord As Variant
Dim bfound As Boolean
   On Error GoTo ErrorHandler
   
   For Each oWord In oParagraph.Words
      oWord.Select
'      If oWord.Font.Color <> wdColorBlack And _
'         oWord.Font.Color <> wdColorAutomatic Then
'
'      End If
   Next oWord
    
   Exit Function
ErrorHandler:
   Para_FindBlueText = False
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

FormatSpacing

Formats the spacing of the current paragraph.

Public Sub Para_FormatSpacing(SpBefore As Integer, _
                       SPAfter As Integer, _
                       sLineSpType As String, _
                       Optional vLineSp As Variant)

Const sPROCNAME As String = "Para_FormatSpacing"            'maybe select the whole para
   On Error GoTo AnError
   With Selection.ParagraphFormat
      If sLineSpType = "S" Then .LineSpacingRule = wdLineSpaceSingle
      If sLineSpType = "E" Then .LineSpacingRule = wdLineSpaceExactly
      If sLineSpType = "A" Then .LineSpacingRule = wdLineSpaceAtLeast
      If Not IsMissing(vLineSp) Then .LineSpacing = vLineSp
      .SpaceBefore = SpBefore
      .SpaceAfter = SPAfter
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "format the ")
End Sub

Indent

Indents the contents of the highlighted cells by a given amount either on the left or right.

Public Sub Sel_Indent(sngIndentAmount As Single, _
                      Optional sDirection As String = "LEFT")
Const sPROCNAME As String = "Sel_IndentLeft"
   On Error GoTo AnError

   If sDirection = "LEFT" Then
      Selection.ParagraphFormat.LeftIndent = CentimetersToPoints(sngIndentAmount)
   End If

   If sDirection = "RIGHT" Then
      Selection.ParagraphFormat.RightIndent = CentimetersToPoints(sngIndentAmount)
   End If

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        sDirection & " indent the highlighted cells by """ & sngIndentAmount & """")
End Sub

IsAtEndOfDocument

Public Function Selection_IsAtEndOfDocument() As Boolean
Const sPROCNAME As String = "Selection_IsAtEndOfDocument"

Dim bAtEnd As Boolean

   On Error GoTo ErrorHandler
   
   With Application.Selection
      If (.End = .Start) Then
         bAtEnd = (.End = ActiveDocument.Content.End - 1)
      Else
         bAtEnd = (.End = ActiveDocument.Content.End)
      End If
   End With
   Selection_IsAtEndOfDocument = bAtEnd

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

LineBelowTable

Determines if you are on a line that is directly below a table.

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

'move up one
'check table
'move down

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

Select

Selects the whole of the active paragraph.

Public Sub Para_Select()
Const sPROCNAME As String = "Para_Select"
   On Error GoTo AnError
   Selection.StartOf Unit:=wdParagraph
   Selection.EndOf Unit:=wdParagraph, Extend:=wdExtend
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "select the whole paragraph")
End Sub

Tab_Add

Adds a tab to the current line.

Public Sub Tab_Add()
Const sPROCNAME As String = "Doc_TabAdd"
   On Error GoTo AnError
   Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(1#), _
                                          Alignment:=wdAlignTabLeft, _
                                          Leader:=wdTabLeaderSpaces

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a tab to the current line")
End Sub

TextGet

Returns the text in the active paragraph.

Public Function Para_TextGet() As String
Const sPROCNAME As String = "Para_TextGet"
   On Error GoTo AnError
   With Selection
      .StartOf Unit:=wdParagraph
      .EndOf Unit:=wdParagraph, Extend:=wdExtend
      Para_GetText = .Text
   End With
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "")
End Function

Underline

Adds a border line to the current paragraph. The line can either be above or below the paragraph.

Public Sub Para_Underline()
Const sPROCNAME As String = "Para_Underline"
   On Error GoTo AnError
   With Selection
      .StartOf Unit:=wdParagraph
      .EndOf Unit:=wdParagraph, Extend:=wdExtend
      With .ParagraphFormat
'remove the others
       .Alignment - wdAlignParagraphRight
         .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
         .Borders(wdBorderRight).LineStyle = wdLineStyleNone
         .Borders(wdBorderTop).LineStyle = wdLineStyleNone
'add a bottom border
         With .Borders(wdBorderBottom)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .ColorIndex = wdAuto / wdDarkBlue
         End With
         .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
         With .Borders
            .DistanceFromTop = 1
            .DistanceFromBottom = 1
            .DistanceFromLeft = 4
            .DistanceFromRight = 4
            .Shadow = False
         End With
      End With
      With Options
         .DefaultBorderLineStyle = wdLineStyleSingle
         .DefaultBorderLineWidth = wdLineWidth050pt
         .DefaultBorderColorIndex = wdAuto
      End With
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "underline the whole paragraph")
End Sub

WidthFull

Adjusts the current paragraph to full page width.

Public Sub Para_WidthFull()
Const sPROCNAME As String = "Para_WidthFull"
   On Error GoTo AnError
   
    Selection.Paragraphs(1).Range.Select
    Selection.ParagraphFormat.LeftIndent = CentimetersToPoints(-5)
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "adjust the paragraph to full width")
End Sub

WidthText

Adjusts the current paragraph to text width.

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


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