VBA Snippets

BorderBottomAdd

Adds a bottom border to all the selected cells.

Public Sub Sel_BorderBottomAdd(Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_BorderBottomAdd"
   On Error GoTo AnError
   Selection.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
   Selection.Borders(wdBorderBottom).ColorIndex = Return_ShadingColour(sColourKey)
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a border to the bottom of the highlighted cells")
End Sub

BorderBottomRemove

Removes the bottom border from the selected cells.

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


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the border from the bottom of the highlighted cells")
End Sub

BorderLeftAdd

Adds a left border to all the highlighted cells.

Public Sub Sel_BorderLeftAdd(Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_BorderLeftAdd"
   On Error GoTo AnError
   Selection.Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
   Selection.Borders(wdBorderLeft).ColorIndex = Return_ShadingColour(sColourKey)
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a border to the left of the highlighted cells")
End Sub

BorderLeftRemove

Removes the left border from the selected cells.

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


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the border from the left of the highlighted cells")
End Sub

BorderOutsideAdd

Adds an outside border to all the highlighted cells.

Public Sub Sel_BorderOutsideAdd(Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_BorderOutsideAdd"
   On Error GoTo AnError
   With Selection
      .Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
      .Borders(wdBorderTop).ColorIndex = Return_ShadingColour(sColourKey)
      .Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
      .Borders(wdBorderLeft).ColorIndex = Return_ShadingColour(sColourKey)
      .Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
      .Borders(wdBorderBottom).ColorIndex = Return_ShadingColour(sColourKey)
      .Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
      .Borders(wdBorderRight).ColorIndex = Return_ShadingColour(sColourKey)
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a border to the outside of the highlighted cells")
End Sub

BorderOutsideRemove

Removes all the borders from the outside of all the selected cells.

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


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the border from the outside of the highlighted cells")
End Sub

BorderRightAdd

Adds a right border to all the highlighted cells.

Public Sub Sel_BorderRightAdd(Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_BorderRightAdd"
   On Error GoTo AnError
   Selection.Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
   Selection.Borders(wdBorderRight).ColorIndex = Return_ShadingColour(sColourKey)
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a border to the right of the highlighted cells")
End Sub

BorderRightRemove

Removes the right border from the selected cells.

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


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the border from the right of the highlighted cells")
End Sub

BorderTopAdd

Adds a border to the top of the highlighted cells.

Public Sub Sel_BorderTopAdd(Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_BorderTopAdd"
   On Error GoTo AnError
   Selection.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
   Selection.Borders(wdBorderTop).ColorIndex = Return_ShadingColour(sColourKey)
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a border to the top of the highlighted cells")
End Sub

BorderTopAndBottomAdd

Adds a border to both the top and the bottom of all the cells highlighted.

Public Sub Sel_BorderTopAndBottomAdd(Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_BorderTopAndBottomAdd"
   On Error GoTo AnError
   With Selection
      .Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
      .Borders(wdBorderTop).ColorIndex = Return_ShadingColour(sColourKey)
      .Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
      .Borders(wdBorderBottom).ColorIndex = Return_ShadingColour(sColourKey)
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "add a border to the top and bottom of the highlighted cells")
End Sub

BorderTopandBottomRemove

Removes the top and bottom border from the selected cells.

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


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the border from the top and bottom of the highlighted cells")
End Sub

BorderTopRemove

Removes the top border from the selected cells.

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


   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "remove the border from the top of the highlighted cells")
End Sub

ColsDelete

Deletes all the columns of any cells currently selected.

Public Sub Sel_ColsDelete()
Const sPROCNAME As String = "Sel_ColsDelete"
   On Error GoTo AnError
   Selection.Cells.Delete ShiftCells:=wdDeleteCellsEntireColumn
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "delete the columns of the cells currently selected")
End Sub

Shade

Shades the current selection of cells in the active table.

Public Sub Sel_Shade(sTextureKey As String, _
                     sColourKey As String)
Const sPROCNAME As String = "Sel_Shade"
   On Error GoTo AnError
   With Selection
      If .Shading.Texture <> wdTextureNone = True Then
         .Cells.Shading.Texture = wdTextureNone
      Else
         .Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
         .Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
      End If
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "shade the highlighted cells")
End Sub

ShadedIsIt

Determines if any of the highlighted cells are shaded.

Public Function Sel_ShadedIsIt() As Boolean
Const sPROCNAME As String = "Sel_ShadedIsIt"
   On Error GoTo AnError
   Sel_AnyShaded = (Selection.Shading.Texture <> wdTextureNone)
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "determine if any of the highlighted cells contain shading")
End Function

ShadingClear

Removes all the shading from the highlighted cells.

Public Sub Sel_ShadingClear()
Const sPROCNAME As String = "Sel_ShadingClear"
Dim icolumnnumber%
   On Error GoTo AnError
   Selection.Shading.Texture = wdTextureNone
   Selection.Shading.BackgroundPatternColorIndex = wdNoHighlight
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1, _
        "removes all the shading from the highlighted cells")
End Sub

---

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top