VBA Snippets

Paragraph_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

Paragraph_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

Paragraph_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

Paragraph_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

Paragraph_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

Paragraph_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

Paragraph_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

Paragraph_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

Paragraph_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

Selection_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

Selection_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

Selection_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

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