VBA Snippets
AddNew
Public Sub Table_AddNew(ByRef objDocument As Word.Document, _
ByVal sTableWidth As String, _
ByVal sCaptionStyle As String, _
ByVal iNoOfCols As Integer, _
ByVal iNoOfRows As Integer, _
ByVal iNoOfHeadingRows As Integer, _
ByVal bIncludeSource As Boolean, _
ByVal bAlternateRowShading As Boolean)
Const sPROCNAME As String = "Table_AddNew"
Dim objTable As Word.Table
On Error GoTo ErrorHandler
'Call ProgressBar_Invoke()
'Call ProgressBar_Update("Creating new table ...")
Application.Selection.TypeParagraph
If (sTableWidth = "Indented") Then
Call modReferences.References_CaptionInsert(objDocument, sCaptionStyle)
Else
Call modReferences.References_CaptionInsert(objDocument, sCaptionStyle)
End If
Set objTable = objDocument.Tables.Add(Range:=Application.Selection.Range, _
NumRows:=iNoOfRows, _
NumColumns:=iNoOfCols, _
DefaultTableBehavior:=Word.WdDefaultTableBehavior.wdWord9TableBehavior, _
AutoFitBehavior:=Word.WdAutoFitBehavior.wdAutoFitFixed)
Call modTables.Table_Format(objDocument, objTable, sTableWidth, iNoOfHeadingRows, bAlternateRowShading, False)
If (bIncludeSource = True) Then
With Application.Selection
.Tables(1).Select
.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
.TypeText "Source: [Source]."
' .HomeKey(Unit:=WdUnits.wdLine, Extend:=WdMovementType.wdExtend)
If (sTableWidth = "Indented") Then
' .Style = objDocument.Styles("B-Source")
Else
' .Style = objDocument.Styles("B-Source. Full Width")
End If
' .EndKey(Unit:=Word.WdUnits.wdLine, Extend:=Word.WdMovementType.wdMove)
End With
End If
'gbProgressBar_Running = False
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
AddNewBasic
Public Sub Table_AddNewBasic(ByRef oDocument As Word.Document, _
ByVal sTableWidth As String, _
ByVal sStyleName_Heading As String, _
ByVal sStyleName_Rows As String, _
ByVal iNoOfCols As Integer, _
ByVal iNoOfRows As Integer, _
ByVal iNoOfHeadingRows As Integer)
Const sPROCNAME As String = "Table_AddNew"
Dim oTable As Word.Table
On Error GoTo ErrorHandler
Set oTable = oDocument.Tables.Add(Range:=Application.Selection.Range, _
NumRows:=iNoOfRows, _
NumColumns:=iNoOfCols, _
DefaultTableBehavior:=Word.WdDefaultTableBehavior.wdWord9TableBehavior, _
AutoFitBehavior:=Word.WdAutoFitBehavior.wdAutoFitFixed)
Call modTables.Table_FormatBasic(oDocument, _
oTable, _
sStyleName_Heading, _
sStyleName_Rows)
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Align
Aligns the contents of all the cells in the active table in a given direction. The direction can be either LEFT, RIGHT or CENTER.Public Sub Table_Align(Optional sDirection As String = "LEFT")
Const sPROCNAME As String = "Table_Align"
On Error GoTo AnError
With Selection
.Tables(1).Select
If sDirection = "RIGHT" Then .ParagraphFormat.Alignment = wdAlignParagraphRight
If sDirection = "CENTER" Then .ParagraphFormat.Alignment = wdAlignParagraphCenter
If sDirection = "LEFT" Then .ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"align the contents of all the cells in the active table in the """ & _
sDirection & """ direction)
End Sub
ApplyAlternateShading
Public Sub Table_ApplyAlternateShading(ByVal objTable As Word.Table, _
ByVal enBackgroundPatternRGB As Word.WdColor)
Const sPROCNAME As String = "Table_ApplyAlternateShading"
Dim objRow As Word.Row
Dim irowno As Integer
On Error GoTo ErrorHandler
For irowno = 1 To objTable.Rows.Count
Set objRow = objTable.Rows(irowno)
With objRow.Cells.Shading
.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
.BackgroundPatternColor = enBackgroundPatternRGB
.BackgroundPatternColor = RGB(213, 227, 235)
End With
Next irowno
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
ApplyRowFormatting
Public Function Table_ApplyRowFormatting(ByRef objDocument As Word.Document, _
ByVal objTable As Word.Table, _
ByVal iNoOfHeadingRows As Integer, _
ByVal sRowType As String, _
ByVal bAlternateRowShading As Boolean) As Boolean
Const sPROCNAME As String = "Table_ApplyRowFormatting"
Dim objCell As Word.Cell
' Dim objTableCellFormatInfo As New g_TableCellFormatInfo
Dim blnIsAltRow As Boolean
Dim intStartRow As Integer
Dim intLastRow As Integer
Dim intCurrentRowIndex As Integer
Dim strTargetStyle As String
On Error GoTo ErrorHandler
If (sRowType = "Standard Row") Then
strTargetStyle = "B-Table Text"
intStartRow = iNoOfHeadingRows + 1
intLastRow = objTable.Rows.Count
Else
strTargetStyle = "B-Table Heading"
intStartRow = 1
intLastRow = iNoOfHeadingRows
If intLastRow = 0 Then intLastRow = 1
End If
intCurrentRowIndex = intStartRow
blnIsAltRow = True
For Each objCell In objTable.Range.Cells
If (objCell.RowIndex >= intStartRow) And _
(objCell.RowIndex <= intLastRow) Then
If intCurrentRowIndex < objCell.RowIndex Then
intCurrentRowIndex = intCurrentRowIndex + 1
If (sRowType = "Standard Row") Then
blnIsAltRow = Not blnIsAltRow
End If
End If
'single cell formatting
' With objTableCellFormatInfo
If objCell.Range.Paragraphs.Count > 0 Then
' .ParagraphAlignment = objCell.Range.Paragraphs(1).Alignment
End If
' .Bold = objCell.Range.Bold
' .Italic = objCell.Range.Italic
With objCell
.Shading.Texture = Word.WdTextureIndex.wdTextureNone
.Shading.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
.Shading.BackgroundPatternColor = Word.WdColor.wdColorAutomatic
End With
objCell.Range.Style = strTargetStyle
If objCell.Range.Paragraphs.Count > 0 Then
' objCell.Range.Paragraphs.Alignment = .ParagraphAlignment
End If
' objCell.Range.Bold = .Bold
' objCell.Range.Italic = .Italic
'End With
'heading row formatting
If (sRowType = "Heading Row") Then
With objCell.Shading
.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
.BackgroundPatternColor = RGB(131, 163, 175)
End With
With objCell.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = Word.WdLineStyle.wdLineStyleSingle
.Color = Word.WdColor.wdColorWhite
.LineWidth = Word.WdLineWidth.wdLineWidth150pt
End With
End If
If (sRowType = "Standard Row") And _
(bAlternateRowShading = True) Then
If (bAlternateRowShading = True) Then
objCell.Shading.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
objCell.Shading.BackgroundPatternColor = RGB(213, 227, 235)
End If
End If
End If
objDocument.UndoClear
Next objCell
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
Set objCell = Nothing
Table_ApplyRowFormatting = True
End Function
ApplySimpleRowFormatting
Public Function Table_ApplySimpleRowFormatting(ByVal objTable As Word.Table, _
ByVal sStyleName_Heading As String, _
ByVal sStyleName_Rows As String, _
ByVal iNoOfHeadingRows As Integer, _
ByVal sRowType As String, _
ByVal bUseAlternateShading As Boolean) As Boolean
Const sPROCNAME As String = "Table_ApplySimpleRowFormatting"
Dim objRow As Word.Row
Dim objCell As Word.Cell
Dim blnIsAltRow As Boolean
Dim intStartRow As Integer
Dim intLastRow As Integer
Dim intCurrentRowIndex As Integer
Dim sTargetStyle As String
On Error GoTo ErrorHandler
If (sRowType = "Standard Row") Then
sTargetStyle = sStyleName_Rows
intStartRow = iNoOfHeadingRows + 1
intLastRow = objTable.Rows.Count
End If
If (sRowType = "Heading Row") Then
sTargetStyle = sStyleName_Heading
intStartRow = 1
intLastRow = iNoOfHeadingRows
End If
intCurrentRowIndex = intStartRow
blnIsAltRow = True
If Table_HasVerticallyMergedCells(objTable) = False Then
For Each objRow In objTable.Range.Rows
If (objRow.Index >= intStartRow) And (objRow.Index <= intLastRow) Then
If intCurrentRowIndex < objRow.Index Then
intCurrentRowIndex = intCurrentRowIndex + 1
If (sRowType = "Standard Row") Then
blnIsAltRow = Not blnIsAltRow
End If
End If
With objRow.Cells
.Shading.Texture = Word.WdTextureIndex.wdTextureNone
.Shading.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
.Shading.BackgroundPatternColor = Word.WdColor.wdColorAutomatic
End With
objRow.Range.Style = sTargetStyle
If (sRowType = "Heading Row") Then
With objRow.Cells.Shading
' .ForegroundPatternColor = Word.WdColor.wdColorAutomatic
' .BackgroundPatternColor = RGB(131, 163, 175)
End With
With objRow.Cells.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = Word.WdLineStyle.wdLineStyleSingle
.Color = Word.WdColor.wdColorWhite
.LineWidth = Word.WdLineWidth.wdLineWidth150pt
End With
End If
If (sRowType = "Standard Row") And (bUseAlternateShading = True) Then
If blnIsAltRow Then
objRow.Cells.Shading.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
objRow.Cells.Shading.BackgroundPatternColor = RGB(213, 227, 235)
End If
End If
'Add the bottom border
If (objRow.Index = objTable.Range.Rows.Count) Then
With objRow.Cells.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = Word.WdLineStyle.wdLineStyleSingle
.LineWidth = Word.WdLineWidth.wdLineWidth075pt
.Color = RGB(131, 163, 175)
End With
End If
End If
Next objRow
Else
For Each objCell In objTable.Range.Cells
If (objCell.RowIndex >= intStartRow) And (objCell.RowIndex <= intLastRow) Then
If intCurrentRowIndex < objCell.RowIndex Then
intCurrentRowIndex = intCurrentRowIndex + 1
If (sRowType = "Standard Row") Then
blnIsAltRow = Not blnIsAltRow
End If
End If
With objCell
.Shading.Texture = Word.WdTextureIndex.wdTextureNone
.Shading.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
.Shading.BackgroundPatternColor = Word.WdColor.wdColorAutomatic
End With
objCell.Range.Style = sTargetStyle
If (sRowType = "Heading Row") Then
With objCell.Shading
' .ForegroundPatternColor = Word.WdColor.wdColorAutomatic
' .BackgroundPatternColor = RGB(131, 163, 175)
End With
With objCell.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = Word.WdLineStyle.wdLineStyleSingle
.Color = Word.WdColor.wdColorWhite
.LineWidth = Word.WdLineWidth.wdLineWidth150pt
End With
End If
If (sRowType = "Standard Row") And (bUseAlternateShading = True) Then
If blnIsAltRow Then
objCell.Shading.ForegroundPatternColor = Word.WdColor.wdColorAutomatic
objCell.Shading.BackgroundPatternColor = RGB(213, 227, 235)
End If
End If
'Add the bottom border
If (objCell.RowIndex = objTable.Range.Rows.Count) Then
With objCell.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = Word.WdLineStyle.wdLineStyleSingle
.LineWidth = Word.WdLineWidth.wdLineWidth075pt
.Color = RGB(131, 163, 175)
End With
End If
End If
Next objCell
End If
With objTable.Range.Cells(1)
.LeftPadding = Application.InchesToPoints(0.01)
.RightPadding = Application.InchesToPoints(0.01)
.TopPadding = 0
.BottomPadding = 0
End With
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
BordersAdd
Adds the necessary borders to the active table.Public Sub Table_BordersAdd(iNoOfHeadingRows As Integer, _
Optional sColourKey As String = "DB", _
Optional bTopBorder As Boolean = False, _
Optional bBottomBorder As Boolean = True)
Const sPROCNAME As String = "Table_BordersAdd"
On Error GoTo AnError
With Selection
Call Table_BordersClear
If bTopBorder = True Then
.Tables(1).Rows(1).Select
.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderTop).ColorIndex = Return_ShadingColour(sColourKey)
End If
.Tables(1).Rows(iNoOfHeadingRows + 1).Select
.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderTop).ColorIndex = Return_ShadingColour(sColourKey)
If bBottomBorder = True Then
.Tables(1).Rows(Selection.Tables(1).Range.Rows.count).Select
.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderBottom).ColorIndex = Return_ShadingColour(sColourKey)
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"add the necessary borders to the table")
End Sub
BordersClear
Clears all the borders from the active table.Public Sub Table_BordersClear()
Const sPROCNAME As String = "Table_BordersClear"
On Error GoTo AnError
With Selection
.Tables(1).Select
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleNone
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"clear all the borders from the table")
End Sub
BordersFaintLines
Adds faint lines to the whole of the active table.Public Sub Table_BordersFaintLines()
Const sPROCNAME As String = "Table_BordersFaintLines"
On Error GoTo AnError
Selection.Tables(1).Select
Selection.Tables(1).Borders.Enable = True
Options.DefaultBorderLineStyle = Return_LineStyle("SG")
Options.DefaultBorderLineWidth = Return_LineWidth("050P")
Options.DefaultBorderColorIndex = Return_ShadingColour("G25")
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"add faint line to all the cells in the active table")
End Sub
BordersFormatRow
Public Sub Table_BordersFormatRow(ByVal objRow As Word.Row, _
ByVal bBorderBottom As Boolean, _
ByVal bBorderLeft As Boolean, _
ByVal bBorderRight As Boolean, _
Optional ByVal objLineStyle As Word.WdLineStyle = Word.WdLineStyle.wdLineStyleSingle, _
Optional ByVal objLineWidth As Word.WdLineWidth = Word.WdLineWidth.wdLineWidth150pt, _
Optional ByVal objColor As Word.WdColor = Word.WdColor.wdColorWhite)
Const sPROCNAME As String = "Table_BordersFormat_Row"
On Error GoTo ErrorHandler
If bBorderBottom = True Then
With objRow.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = objLineStyle
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .LineWidth = objLineWidth
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .Color = objColor
End With
End If
If bBorderLeft = True Then
With objRow.Borders(Word.WdBorderType.wdBorderLeft)
.LineStyle = objLineStyle
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .LineWidth = objLineWidth
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .Color = objColor
End With
End If
If bBorderRight = True Then
With objRow.Borders(Word.WdBorderType.wdBorderRight)
.LineStyle = objLineStyle
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .LineWidth = objLineWidth
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .Color = objColor
End With
End If
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
BordersFormatSelection
Public Sub Table_BordersFormatSelection(ByVal objSelection As Word.Selection, _
ByVal bBorderBottom As Boolean, _
ByVal bBorderLeft As Boolean, _
ByVal bBorderRight As Boolean, _
Optional ByVal objLineStyle As Word.WdLineStyle = Word.WdLineStyle.wdLineStyleNone, _
Optional ByVal objLineWidth As Word.WdLineWidth = Word.WdLineWidth.wdLineWidth075pt, _
Optional ByVal objColor As Word.WdColor = Word.WdColor.wdColorWhite)
Const sPROCNAME As String = "Table_BordersFormatSelection"
On Error GoTo ErrorHandler
If bBorderBottom = True Then
With objSelection.Borders(Word.WdBorderType.wdBorderBottom)
.LineStyle = objLineStyle
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .LineWidth = objLineWidth
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .Color = objColor
End With
End If
If bBorderLeft = True Then
With objSelection.Borders(Word.WdBorderType.wdBorderLeft)
.LineStyle = objLineStyle
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .LineWidth = objLineWidth
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .Color = objColor
End With
End If
If bBorderRight = True Then
With objSelection.Borders(Word.WdBorderType.wdBorderRight)
.LineStyle = objLineStyle
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .LineWidth = objLineWidth
If (objLineStyle <> Word.WdLineStyle.wdLineStyleNone) Then .Color = objColor
End With
End If
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Cell_Bold
Bolds the contents of a given cell. If now row and column is specified then the active cell is used.Public Sub Cell_Bold(Optional ByVal bBold As Boolean = True, _
Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1)
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Selection.Tables(1).cell(iRowNo, iColNo).Range.Font.Bold = bBold
Else
Selection.Cells(1).Range.Font.Bold = bBold
End If
If gbDEBUG = False Then Exit Sub
AnError:
'Need to determine if active cell or given cell ?
Call Error_Handle("Cell_Bold", msMODULENAME, 1, _
"bold the contents of cell (" & iColNo & "," & iRowNo & ")")
End Sub
Cell_BoldIsIt
Determines if the contents of the given cell is in Bold.Public Function Cell_BoldIsIt(Optional ByVal iRowNo As Integer = -1, _
Optional ByVal iColNo As Integer = -1) _
As Boolean
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Cell_BoldIsIt = Selection.Tables(1).cell(iRowNo, iColNo).Range.Font.Bold
Else
Cell_BoldIsIt = Selection.Cells(1).Range.Font.Bold
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_BoldIsIt", msMODULENAME, 1, _
"determine if the contents of the cell (" & iColNo & "," & iRowNo & ")" & _
" is in bold")
End Function
Cell_Exists
Determines if a particular cell (given a row & column index) exists in the active table.Public Function Cell_Exists(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
Optional ByVal bInformUser As Boolean = False) _
As Boolean
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Cell_Exists = (Selection.Tables(1).cell(iRowNo, iColNo).Height > 0)
Else
Cell_Exists = (Selection.Cells(1).Height > 0)
End If
If gbDEBUG = False Then Exit Function
AnError:
Cell_Exists = False
If bInformUser = True Then
Call Error_Handle("Cell_Exists", msMODULENAME, 1, _
"Cell (" & iColNo & "," & iRowNo & ") does not exist")
End If
End Function
Cell_Format
Public Sub Cell_Format(ByVal iRowNo As Integer, _
ByVal iColNo As Integer, _
ByVal enShadingTextureIndex As WdTextureIndex, _
ByVal enShadingColourIndex As WdColorIndex, _
Optional ByVal objRange As Word.Range = Nothing)
On Error GoTo AnError
If (objRange Is Nothing) Then
Set objRange = Selection.Tables(1).Cell(iRowNo, iColNo).Range
End If
With objRange
.Shading.Texture = enShadingTextureIndex
.Shading.ForegroundPatternColorIndex = enShadingColourIndex
.Font.Bold = True
.Font.Italic = True
End With
Exit Sub
AnError:
Call MsgBox( _
"apply the formatting this this cell")
End Sub
Cell_MoveDown
Moves to the cell directly below a particular cell.Public Sub Cell_MoveDown(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
Optional ByVal bInHeadingRows As Boolean = True)
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
If bInHeadingRows = True Then
.Tables(1).cell(iRowNo, iColNo).Select
icolumnnumber = 1
Do
.Tables(1).cell(iRowNo + 1, icolumnnumber).Select
.MoveUp wdLine, 1
If .IsEndOfRowMark = True Then .MoveLeft wdCharacter, 1 'move back into table
If .Cells(1).ColumnIndex < iColNo Then
icolumnnumber = icolumnnumber + 1
Else: Exit Do '************* added
End If
Loop Until .Cells(1).ColumnIndex = iColNo 'active cell column number equals
.Tables(1).cell(iRowNo + 1, icolumnnumber).Select
Else
.Tables(1).cell(iRowNo + 1, iColNo).Select
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveDown", msMODULENAME, 1, _
"move to the cell below cell (" & iColNo & "," & iRowNo & ")")
End Sub
Cell_MoveLeft
Moves to the cell directly to the left of a particular cell.Public Sub Cell_MoveLeft(ByVal iColNo As Integer, _
ByVal iRowNo As Integer)
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
If iColNo > 1 Then 'if not the left most column
.Characters(1).Select
.MoveLeft wdWord, 2
.Cells(1).Select
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveLeft", msMODULENAME, 1, _
"move to the cell on the left of cell (" & iColNo & "," & iRowNo & ")")
End Sub
Cell_MoveLeftNo
Moves a given number of cells to the left of a particular cell.Public Sub Cell_MoveLeftNo(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
ByVal iNoAcross As Integer)
Dim icolumncounter As Integer
On Error GoTo AnError
Selection.Tables(1).cell(iRowNo, iColNo).Select
For icolumncounter = 1 To iNoAcross
Call Cell_MoveRight(iRowNo, iColNo + icolumncounter - 1)
Next icolumncounter
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveLeftNo", msMODULENAME, 1, _
"move " & iNoAcross & " cells to the left of cell " & _
"(" & iColNo & "," & iRowNo & ")")
End Sub
Cell_MoveRight
Moves to the cell directly to the right of a particular cell.Public Sub Cell_MoveRight(ByVal iColNo As Integer, _
ByVal iRowNo As Integer)
Dim itotalcolumns As Integer
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
.Tables(1).Rows(iRowNo).Select
itotalcolumns = .Columns.count
If iColNo < itotalcolumns Then
.Tables(1).cell(iRowNo, iColNo).Select
.MoveRight wdCell, 1
.Cells(1).Select
Else
.Tables(1).cell(iRowNo, iColNo).Select
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveRight", msMODULENAME, 1, _
"move to the cell on the right of cell (" & iColNo & "," & iRowNo & ")")
End Sub
Cell_MoveRightNo
Moves to the cell a given number of cells to the right of a particular cell.Public Sub Cell_MoveRightNo(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
ByVal iNoAcross As Integer)
Dim icolumncounter As Integer
On Error GoTo AnError
Selection.Tables(1).cell(iRowNo, iColNo).Select
For icolumncounter = 1 To iNoAcross
Call Cell_MoveRight(iRowNo, iColNo + icolumncounter - 1)
Next icolumncounter
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveRightNo", msMODULENAME, 1, _
"move " & iNoAcross & " cells to the right of cell " & _
"(" & iColNo & "," & iRowNo & ")")
End Sub
Cell_MoveUp
Moves to the cell directly above a particular cell.Public Sub Cell_MoveUp(ByVal iColNo As Integer, _
ByVal iRowNo As Integer)
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
If iRowNo > 1 Then
If iColNo > 1 Then
If Cell_RowLastIsItOn(iRowNo, iColNo) = False Then
Call Cell_MoveLeft(iRowNo, iColNo)
If Cell_HeadingShareRHCell(iRowNo, .Cells(1).ColumnIndex) = False Then
Call Cell_MoveUpSpecific
Call Cell_MoveRight(iRowNo - 1, .Cells(1).ColumnIndex)
Else
Call Cell_MoveUpSpecific
End If
Else
Call Cell_MoveUpSpecific
If .IsEndOfRowMark Then .MoveLeft wdCharacter, 1
End If
.Cells(1).Select
Else
.Tables(1).cell(iRowNo - 1, 1).Select
End If
Else
.Tables(1).cell(iRowNo, iColNo).Select
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveUp", msMODULENAME, 1, _
"move to the cell above the cell (" & iColNo & "," & iRowNo & ")")
End Sub
Cell_ShadingHas
Determines if a particular cell contains any shading.Public Function Cell_ShadingHas(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1) _
As Boolean
On Error GoTo AnError
With Selection
Cell_ShadingHas = True
If (iRowNo > -1) And (iColNo > -1) Then
If (.Tables(1).cell(iRowNo, iColNo).Shading.Texture = wdTextureNone And _
.Tables(1).cell(iRowNo, iColNo).Shading.ForegroundPatternColorIndex = _
wdNoHighlight) Then _
Cell_ShadingHas = False
Else
If (.Cells(1).Shading.Texture = wdTextureNone And _
.Cells(1).Shading.ForegroundPatternColorIndex = wdNoHighlight) Then _
Cell_ShadingHas = False
End If
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_ShadingHas", msMODULENAME, 1, _
"determine if the active cell has any shading applied to it")
End Function
CellCharSelect
Selects a particular character in a cell in a table ??.Public Sub Table_CellCharSelect(iCharNo as Integer)
Const sPROCNAME As String = "Table_CellCharSelect"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
CellContainsText
Determines if a cell in a table in the active document contains any text. Returns True or False.Public Function Table_CellContainsText(iRowNo As Integer, _
iColNo As Integer, _
Optional iTableNo As Integer = 1) As Boolean
Const sPROCNAME As String = "Table_CellContainsText"
On Error GoTo AnError
ActiveDocument.Tables(iTableNo).Cell(iRowNo, iColNo).Select
Selection.MoveLeft wdCharacter, 1, wdExtend
If Selection.Characters.Count = 1 Then Table_CellContainsText = False
If Selection.Characters.Count > 1 Then Table_CellContainsText = True
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"determine if there is any text in the cell")
End Function
CellContentsWidth
Returns the total width of any given text.Public Function Table_CellContentsWidth(sText As String, _
bIsItBold As Boolean) As Single
Const sPROCNAME As String = "Table_CellContentsWidth"
Dim sChar$, scurrenttext$, sngtotalwidth!
On Error GoTo AnError
sngtotalwidth = Selection.ParagraphFormat.LeftIndent 'include any indent
scurrenttext = sText
Do Until (scurrenttext = "")
sChar = Left(scurrenttext, 1)
If bIsItBold = True Then sngtotalwidth = sngtotalwidth + Char_ArialNarrow9Reg(sChar)
If bIsItBold = False Then sngtotalwidth = sngtotalwidth + Char_ArialNarrow9Reg(sChar)
scurrenttext = Right(scurrenttext, Len(scurrenttext) - 1) 'remove first char
Loop
Table_CellContentsWidth = sngtotalwidth
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the total width of the text " & sText & " in reg or bold ?")
End Function
CellHeightGet
Returns the height of the text in a cell.Public Function Table_CellHeightGet(iTableNo As Integer, _
iRowNo As Integer, _
iColNo As Integer) As Long
Const sPROCNAME As String = "Table_CellHeightGet"
Dim ltotalheight&, irowindex%
On Error GoTo AnError
ActiveDocument.Tables(iTableNo).Rows(iRowNo).Select
If Selection.Cells.HeightRule = wdRowHeightExactly Then
ltotalheight = Selection.Cells.Height
Else
With Selection
ActiveDocument.Tables(iTableNo).Cell(iRowNo, iColNo).Select
.MoveLeft wdCharacter, 1
Do While (.Cells(1).RowIndex = iRowNo) And _
(.Information(wdWithInTable) = True)
ltotalheight = ltotalheight + .ParagraphFormat.LineSpacing
.EndKey wdLine
If .Characters(1).Text = Chr(13) Then
ltotalheight = ltotalheight + .ParagraphFormat.SpaceBefore
ltotalheight = ltotalheight + .ParagraphFormat.SpaceAfter
End If
.HomeKey wdLine
.MoveDown wdLine, 1
Loop
End With
End If
Selection.MoveUp wdLine, 1
ltotalheight = ltotalheight + Selection.ParagraphFormat.SpaceBefore
ltotalheight = ltotalheight + Selection.ParagraphFormat.SpaceAfter
Table_CellHeightGet = ltotalheight
If gbDEBUG = False Then Exit Function
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"return the height of the text in the cell")
End Function
CellHeightIncrease
Increases the line spacing after the paragraph in a given cell.Public Sub Table_CellHeightIncrease(iTableNo As Integer, _
iRowNo As Integer, _
iColNo As Integer, _
lIncreaseEndSpacing As Long)
Const sPROCNAME As String = "Table_CellHeightIncrease"
Dim irowindex%
On Error GoTo AnError
ActiveDocument.Tables(iTableNo).Cell(iRowNo, iColNo).Select
With Selection
.MoveLeft wdCharacter, 1
.MoveDown wdLine, 1
irowindex = .Cells(1).RowIndex
Do While (irowindex = iRowNo)
.MoveDown wdLine, 1
irowindex = .Cells(1).RowIndex
Loop
.MoveUp wdLine, 2
.StartOf wdParagraph
.EndOf wdParagraph, wdExtend
.ParagraphFormat.SpaceAfter = .ParagraphFormat.SpaceAfter + lIncreaseEndSpacing
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"increase the line spacing after the paragraph of the active cell")
End Sub
CellMoveToEnd
Moves to the end of the text in a given cell.Public Sub Table_CellMoveToEnd(iTableNo As Integer, _
iRowNo As Integer, _
iColNo As Integer)
Const sPROCNAME As String = "Table_CellMoveToEnd"
Dim irowindex%
On Error GoTo AnError
ActiveDocument.Tables(iTableNo).Cell(iRowNo, iColNo).Select
Selection.MoveRight wdCharacter, 1
Selection.MoveLeft wdCharacter, 1
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"move to the end of the text in cell ????")
End Sub
Cells_BelowSameWidth
Adjusts the width of all the cells below a particular cell in that column to have the same width.Public Sub Cells_BelowSameWidth(ByVal iRowNo As Integer, _
ByVal iColNo As Integer, _
ByVal iNoOfRows As Integer, _
ByVal sngSetWidth As Single)
Dim irownumber As Integer
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Width = sngSetWidth
For irownumber = iRowNo To (iNoOfRows - 1)
Call Cell_MoveDown(irownumber, iColNo)
.Cells(1).Width = sngSetWidth
Next
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cells_BelowSameWidth", msMODULENAME, 1, _
"determine if all the cells below cell (" & iColNo & "," & iRowNo & ") " & _
"have the same widths")
End Sub
Cells_Merge
Merges a selection of cells in the active table and justifies the contents.Public Sub Cells_Merge(Optional ByVal iRowNo As Integer = -1, _
Optional ByVal iColNo As Integer = -1, _
Optional ByVal iNoOfRowsAcross As Integer = 0, _
Optional ByVal iNoOfColsDown As Integer = 0, _
Optional ByVal sDirection As String = "CENTER")
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
If iNoOfRowsAcross > 0 Then _
.MoveRight wdCharacter, iNoOfRowsAcross - 1, wdExtend
If iNoOfColsDown > 0 Then .MoveDown wdLine, iNoOfColsDown - 1, wdExtend
.Cells.Merge
If sDirection = "RIGHT" Then .ParagraphFormat.Alignment = wdAlignParagraphRight
If sDirection = "CENTER" Then .ParagraphFormat.Alignment = wdAlignParagraphCenter
If sDirection = "LEFT" Then .ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cells_Merge", msMODULENAME, 1, _
"merge the selection of cells and justify the contents")
End Sub
Cells_Select
Selects a particular range of cells in the active table.Public Sub Table_CellsSelect(iRowNo as Integer, _
iCoNo as Integer, _
iNoOfRows as Integer, _
iNoOfCols as Integer)
Const sPROCNAME As String = "Table_CellsSelect"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
Cells_Sort
Sorts a particular range of cells in the actibe table.Public Sub Table_CellsSort(iRowNo as Integer, _
iColNo as Integer, _
iNoOfRows as Integer, _
iNoOfCols as Integer)
Const sPROCNAME As String = "Table_CellsSort"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"sort the following range of cells "---" in the active table")
End Sub
CellText
Returns the text that is in a particular cell of a table.Public Function Table_CellText(iTableNo As Integer, _
iRowNo As Integer, _
iColNo As Integer) As String
Const sPROCNAME As String = "Table_CellText"
Dim itextlength%, inoofchars%, sTextConcat$
On Error GoTo AnError
sTextConcat = ""
With ActiveDocument.Tables(iTableNo)
itextlength = .Cell(iRowNo, iColNo).Range.Characters.Count
For inoofchars = 1 To (itextlength - 1)
sTextConcat = sTextConcat & _
.Cell(iRowNo, iColNo).Range.Characters(inoofchars)
Next inoofchars
End With
Table_CellText = sTextConcat
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the text that is in the cell")
End Function
CellTextGet
Public Function Table_CellTextGet(iTableNo As Integer, _
iRowNo As Integer, _
iColNo As Integer) As String
Const sPROCNAME As String = "Table_CellTextGet"
Dim itextlength%, inoofchars%, sTextConcat$
On Error GoTo AnError
sTextConcat = ""
With ActiveDocument.Tables(iTableNo)
itextlength = .Cell(iRowNo, iColNo).Range.Characters.Count
For inoofchars = 1 To (itextlength - 1)
sTextConcat = sTextConcat & _
.Cell(iRowNo, iColNo).Range.Characters(inoofchars)
Next inoofchars
End With
Table_CellTextGet = sTextConcat
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the text in the cell")
End Function
CellWordSelect
Selects a particular word in a cell in a table.Public Sub Table_CellWordSelect(iWordNo as Integer)
Const sPROCNAME As String = "Table_CellWordSelect"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
CharsNoOfShow
Displays a userform displaying the total number of characters in a particular cell in the active table.Public Sub Cell_CharsNoOfShow(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1)
Dim lnoofcharacters As Long
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
lnoofcharacters = Selection.Tables(1).cell(iRowNo, iColNo).Range.Characters.count
Else
lnoofcharacters = Selection.Cells(1).Range.Characters.count
End If
' Call Frm_Inform("", _
Call Msgbox( _
"Cell has " & lnoofcharacters & " characters")
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_CharsNoOfShow", msMODULENAME, 1, _
"display the total number of characters in cell (" & iColNo & "," & iRowNo & ")")
End Sub
ChartHolderInsert
Inserts a table that will be used to display a chart.Public Sub Table_ChartHolderInsert(sTypeName As String)
Const sPROCNAME As String = "Table_ChartHolderInsert"
On Error GoTo AnError
Select Case sTypeName
Case "Standard": Call Chart_BoxInsert(3, 1, 50, 0)
Case "Full width": Call Chart_BoxInsert(3, 1, 50, 0)
Case "X2": Call Chart_BoxInsert(3, 1, 50, 0)
Case "X3": Call Chart_BoxInsert(3, 1, 50, 0)
End Select
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"insert a (1 x 1) table to be used as a chart place holder")
End Sub
ClearAllFormatting
Public Sub Table_ClearAllFormatting(ByVal objTable As Word.Table)
Const sPROCNAME As String = "Table_ClearAllFormatting"
On Error GoTo ErrorHandler
'oApplication.UpdateStatusBar("Clearing existing table formatting...")
With objTable
.AllowAutoFit = False
'Clear all table formats
.Borders(Word.WdBorderType.wdBorderLeft).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderRight).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderTop).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderBottom).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderHorizontal).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderVertical).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderDiagonalDown).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders(Word.WdBorderType.wdBorderDiagonalUp).LineStyle = Word.WdLineStyle.wdLineStyleNone
.Borders.Shadow = False
.TopPadding = Application.CentimetersToPoints(0)
.BottomPadding = Application.CentimetersToPoints(0)
.LeftPadding = Application.CentimetersToPoints(0)
.RightPadding = Application.CentimetersToPoints(0)
.Spacing = 0
.AllowPageBreaks = True
'.AutoFitBehavior(Word.WdAutoFitBehavior.wdAutoFitWindow) '<-- commented out 21 Dec 2009
.Rows.HeightRule = Word.WdRowHeightRule.wdRowHeightAuto
.Rows.Height = Application.CentimetersToPoints(0)
End With
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Col_Align
Defines the alignment of all the cells in a particular column in the active table.Public Sub Col_Align(iColNo As Integer, _
Optional sDirection As String = "CENTER")
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
.Tables(1).cell(1, iColNo).Select
Selection.SelectColumn
'CHECK THE DIRECTION !!
If sDirection = "RIGHT" Then .ParagraphFormat.Alignment = wdAlignParagraphRight
If sDirection = "CENTER" Then .ParagraphFormat.Alignment = wdAlignParagraphCenter
If sDirection = "LEFT" Then .ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_Align", msMODULENAME, 1, _
sDirection & " align the column " & iColNo)
End Sub
Col_Bold
Defines all the text to be bold in all the cells in a particular column in the active table.Public Sub Col_Bold(Optional iColNo As Integer = -1)
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
If iColNo > -1 Then iColNo = .Cells(1).ColumnIndex
.Tables(1).cell(1, iColNo).Select
Selection.SelectColumn
.Font.Bold = True
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_Bold", msMODULENAME, 1, _
"bold the column " & iColNo)
End Sub
Col_FontColour
Defines the colour of the font of all the text in a particular column in the active table.Public Sub Col_FontColour(ByVal sColourKey As String, _
Optional ByVal iColNo As Integer = -1)
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
If iColNo > -1 Then iColNo = .Cells(1).ColumnIndex
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_FontColour", msMODULENAME, 1, _
"change the colour of the font in column " & iColNo)
End Sub
Col_Select
Selects a particular column in the active table.Public Sub Col_Select(Optional iColNo As Integer = -1)
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
If iColNo > -1 Then iColNo = .Cells(1).ColumnIndex
'select the column !!
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_Select", msMODULENAME, sPROCNAME, 1,
"select the column ,,,,")
End Sub
Col_Shade
Shades a particular column in the active table.Public Sub Col_Shade(sTextureKey As String, _
sColourKey As String, _
Optional iColNo As Integer = -1, _
Optional bIncludeHeadings As Boolean = False)
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
' !!!!!!! adjust so it doesn't shade the heading rows
icolumnnumber = .Cells(1).ColumnIndex 'active cell column number
.Tables(1).Columns(icolumnnumber).Shading.Texture = _
Return_ShadingTexture(sTextureKey)
.Tables(1).Columns(icolumnnumber).Shading.ForegroundPatternColorIndex = _
Return_ShadingColour(sColourKey)
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_Shade", msMODULENAME, 1, _
"shade the column number " & Selection.Cells(1).ColumnIndex)
End Sub
Col_ShadeFromCell
Shades all the cells in a particular column below the active cell.Public Sub Col_ShadeFromCell(sTextureKey As String, _
sColourKey As String, _
Optional iColNo As Integer)
Dim irownumber As Integer
Dim itotalrows As Integer
On Error GoTo AnError
With Selection
irownumber = .Cells(1).RowIndex 'active cell row number
itotalrows = .Tables(1).Range.Rows.count
.MoveDown wdLine, itotalrows - irownumber, wdExtend
'selects the remaining row
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_ShadeFromCell", msMODULENAME, 1, _
"shade the column from the active cell downwards the colour " & sColourKey)
End Sub
Col_ShadingClear
Removes all the shading from a particular column.Public Sub Col_ShadingClear(Optional iColNo As Integer = -1)
On Error GoTo AnError
With Selection
If iColNo > -1 Then .Tables(1).cell(1, iColNo).Select
.Tables(1).Columns(.Cells(1).ColumnIndex).Select 'selects the whole column
.Cells.Shading.Texture = wdTextureNone
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_ShadingClear", msMODULENAME, 1, _
"removes all the shading from the column number " & Selection.Cells(1).ColumnIndex)
End Sub
Col_Width
Adjusts the width of a particular column.Public Sub Col_Width(sngWidth As Single, _
Optional iColNo As Integer = -1)
On Error GoTo AnError
With Selection
.Tables(1).cell(1, iColNo).Select
Selection.SelectColumn
.Columns.SetWidth ColumnWidth:=InchesToPoints(sngWidth), RulerStyle:=wdAdjustNone
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_Width", msMODULENAME, 1, _
"adjust the width of the column " & iColNo & " to """ & sngWidth & """")
End Sub
Col_WidthDecrease
Decreases the width of a particular column in the active table.Public Sub Col_WidthDecrease(Optional iDecreaseAmount As Integer = 20, _
Optional iColNo As Integer = -1)
Dim lnewwidth As Long
On Error GoTo AnError
With Selection
.SelectColumn
lnewwidth = .Columns.Width - iDecreaseAmount
.Columns.SetWidth ColumnWidth:=lnewwidth, RulerStyle:=wdAdjustNone
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_WidthDecrease", msMODULENAME, 1,
"decrease the width of the column number " & iColNo & _
" by """ & iDecreaseAmount & """")
End Sub
Col_WidthIncrease
Increases the width of a particular column in the active table.Public Sub Col_WidthIncrease(Optional iIncreaseAmount As Integer = 20, _
Optional iColNo As Integer = -1)
Dim lnewwidth As Long
On Error GoTo AnError
With Selection
.SelectColumn
lnewwidth = .Columns.Width + iIncreaseAmount
.Columns.SetWidth ColumnWidth:=lnewwidth, RulerStyle:=wdAdjustNone
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_WidthIncrease", msMODULENAME, 1, _
"increase the width of the column number " & iColNo & _
" by """ & iIncreaseAmount & """")
End Sub
ColFirstIsItOn
Determines if a particular cell is in the first column of the active table.Public Function Cell_ColFirstIsItOn(ByVal iColNo As Integer, _
ByVal iRowNo As Integer) As Boolean
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_ColFirstIsItOn", msMODULENAME, 1, _
"determine if the cell (" & iColNo & "," & iRowNo & ")" _
"is in the first column of the active table")
End Function
ColIndex
Returns the index number of the currently active cell. This contains error handling and should be used for TESTING.Public Function Cell_ColIndex() As Integer
On Error GoTo AnError
Cell_ColIndex = Selection.Cells(1).ColumnIndex
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_ColIndex", msMODULENAME, 1, _
"return the column index of the active cell")
End Function
ColLastIsItOn
Determines if a particular cell is in the last column of the active table.Public Function Cell_ColLastIsItOn(ByVal iColNo As Integer, _
ByVal iRowNo As Integer) _
As Boolean
Dim itotalcolumns As Integer
On Error GoTo AnError
With Selection
.Tables(1).Rows(iRowNo).Select
itotalcolumns = .Columns.count
If iColNo < itotalcolumns Then Cell_RowLastIsItOn = False
If iColNo = itotalcolumns Then Cell_RowLastIsItOn = True
.Tables(1).cell(iRowNo, iColNo).Select ' NEED?
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_ColLastIsItOn", msMODULENAME, 1, _
"determine if the cell (" & iColNo & "," & iRowNo & ")" & _
" is in the last column of the active table")
End Function
Cols_BlankDelete
Deletes all the blank columns from the active table. Note that the columns are deleted in reverse order.Public Sub Table_ColsBlankDelete()
Const sPROCNAME As String = "Table_ColsBlankDelete"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
Cols_Bold
Defines all the text to be bold in all the particualr columns in the active table.Public Sub Cols_Bold()
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cols_Bold", msMODULENAME, 1, _
"")
End Sub
Cols_DistributeAmountBelow
Distributes a given amount of space evenly to all the columns / cells below a given heading row cell.Public Sub Table_ColsDistributeAmountBelow(iRowNo As Integer, _
iColNo As Integer, _
iNoOfHeadingRows As Integer, _
sngAdditionalWidth As Single)
Const sPROCNAME As String = "Table_ColsDistributeAmountBelow"
Dim icolumncounter As Integer
Dim inoofmergedcolumns As Integer
Dim sngNewCellWidth As Single
Dim sngDifference As Single
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
inoofmergedcolumns = Cell_HeadingIsItMerged(iRowNo, iColNo, iNoOfHeadingRows)
If inoofmergedcolumns > 0 Then 'cell is a merged heading
For icolumncounter = 1 To inoofmergedcolumns + 1
Call Cell_MoveDown(iRowNo, iColNo) 'move to cell below given cell
Call Cell_MoveRightNo(iRowNo + 1, .Cells(1).ColumnIndex, icolumncounter - 1)
'moves across for all the rows below
Call Table_ColsDistributeAmountBelow(iRowNo + 1, _
.Cells(1).ColumnIndex, _
iNoOfHeadingRows, _
sngAdditionalWidth / (inoofmergedcolumns + 1))
Next icolumncounter
Else 'cell is not merged above the cell below
If (iRowNo < iNoOfHeadingRows) Then
.Tables(1).cell(iRowNo, iColNo).Select 'select the given cell
Call Cell_MoveDown(iRowNo, iColNo) 'move to cell below given cell
Call Table_ColsDistributeAmountBelow(iRowNo + 1, _
.Cells(1).ColumnIndex, _
iNoOfHeadingRows, _
sngAdditionalWidth)
Else
sngNewCellWidth = .Cells(1).Width + sngAdditionalWidth
sngDifference = sngNewCellWidth - _
.Tables(1).cell(iNoOfHeadingRows, iColNo).Width
Call Table_HeadingRowsAdjustBelow(iColNo, _
iNoOfHeadingRows, _
sngDifference) 'adjust heading rows
Call Table_RowsDataAdjustBelow(iColNo, _
iNoOfHeadingRows, _
sngNewCellWidth) 'adjust data rows
End If
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"distribute " & sngAdditionalWidth & " evenly " & _
"to all the cells / columns below cell (" & iRowNo & "," & iColNo & ")")
End Sub
Cols_IncreaseToWidth
Expands all the columns in the active table to the required width.Public Sub Table_ColsIncreaseToWidth(iNoOfHeadingRows As Integer, _
sngWidthOfTable As Single) 'passed in pts
Const sPROCNAME As String = "Table_ColsIncreaseToWidth"
'!!!!!!!!!!!!!!!!!! does all the columns an even amount !!
Dim sngamountofspace!, sngadjustedamount!, sngNewCellWidth!
Dim icolumnnumber%, itotalcolumns%
On Error GoTo AnError
With Selection
itotalcolumns = .Tables(1).Range.Columns.count 'table total number of columns
If sngWidthOfTable = sngDEF_WIDTHTEXTPAGE Then _
.Tables(1).Rows.SetLeftIndent _
-(sngDEF_INDENTTEXTWIDTH + sngDEF_COLINDENTLEFT), wdAdjustNone
If sngWidthOfTable = sngDEF_WIDTHFULLPAGE Then _
.Tables(1).Rows.SetLeftIndent _
-(sngDEF_INDENTFULLWIDTH + sngDEF_COLINDENTLEFT), wdAdjustNone
If sngWidthOfTable = sngDEF_WIDTHLANDSCAPE Then _
.Tables(1).Rows.SetLeftIndent _
-(sngDEF_INDENTLANDSCAPEWIDTH + sngDEF_COLINDENTLEFT), wdAdjustNone
sngamountofspace = sngWidthOfTable - Cols_Width 'current gap after the table
sngadjustedamount = sngamountofspace
If sngamountofspace > 0 Then
For icolumnnumber = 1 To itotalcolumns
.Tables(1).cell(iNoOfHeadingRows, icolumnnumber).Select 'last heading cell
sngNewCellWidth = .Cells(1).Width + sngamountofspace / itotalcolumns
Call Table_HeadingRowsAdjustBelow(icolumnnumber, _
iNoOfHeadingRows, _
sngamountofspace / itotalcolumns)
Call Table_RowsDataAdjustBelow(icolumnnumber, _
iNoOfHeadingRows, _
sngNewCellWidth)
sngadjustedamount = sngadjustedamount - (sngamountofspace / itotalcolumns)
Next
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"expand the columns in the table to the required width")
End Sub
Cols_Indent
Indents all the columns in a block by a given amount on either the LEFT or RIGHT.Public Sub Table_ColsIndent(iColFirst As Integer, _
Optional iColLast As Integer = 0, _
Optional sngIndentAmount As Single = sngDEF_COLINDENTLEFT, _
Optional sDirection As String = "LEFT")
Const sPROCNAME As String = "Table_ColsIndent"
Dim icolumncounter%
On Error GoTo AnError
If iColLast = 0 Then iColLast = iColFirst
With Selection
For icolumncounter = iColFirst To iColLast
.Tables(1).cell(1, icolumncounter).Select 'select the first cell in column
.MoveDown wdLine, .Rows.count - 1, wdExtend
'check if it is left or right !
If sDirection = "LEFT" Then _
.ParagraphFormat.LeftIndent = sngIndentAmount
If sDirection = "RIGHT" Then _
.ParagraphFormat.RightIndent = sngIndentAmount
Next icolumncounter
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"indent all the columns from " & iColFirst & " to " & iColLast & _
" by " & sngIndentAmount)
End Sub
Cols_Insert
Displays a userform and allows the user to insert a given number of columns.Public Sub Cols_Insert()
Dim itotalcolumns As Integer
On Error GoTo AnError
Call Frm_GetInput("", "Number of cols to insert: ", "Insert")
itotalcolumns = CInt(gsResponse)
If IsNumeric(itotalcolumns) And itotalcolumns > 0 Then
Call Cols_InsertNo(itotalcolumns)
Else
Call Frm_Inform("", "Incorrect number of columns!")
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cols_Insert", msMODULENAME, 1, _
"insert " & itotalcolumns & " columns into the table")
End Sub
Cols_InsertNo
Inserts a given number of columns into the active table.Public Sub Cols_InsertNo(iNoOfCols As Integer)
On Error GoTo AnError
While iNoOfCols > 0
Selection.InsertColumns
iNoOfCols = iNoOfCols - 1
Wend
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Col_InsertNo", msMODULENAME, 1, _
"insert " & iNoOfCols & " columns into the table")
End Sub
Cols_NoOfShow
Displays a userform showing the total number of columns in the active table.Public Sub Cols_NoOfShow()
Dim itotalcolumns As Integer
On Error GoTo AnError
With Selection
.Tables(1).Rows(.Cells(1).RowIndex).Select
itotalcolumns = .Columns.count
End With
Call Frm_Inform("", "Total number of columns in this row is: " & itotalcolumns)
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cols_NoOfShow", msMODULENAME, 1, _
"display the number of columns in the row of the active cell")
End Sub
Cols_Reduce
Reduces all the columns in the active table to their minimum width.Public Sub Table_ColsReduce(iNoOfHeadingRows As Integer)
Const sPROCNAME As String = "Table_ColsReduce"
Dim icolumncounter%, itotalcolumns%, sngtopheadingwidth!
On Error GoTo AnError
With Selection
.Tables(1).Rows(1).Select
itotalcolumns = Selection.Columns.count
For icolumncounter = 1 To itotalcolumns
Call Table_ColsReduceAll(1, icolumncounter, iNoOfHeadingRows, 0)
Next icolumncounter
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"reduce all the columns in the table to their minimum widths")
End Sub
Cols_ReduceAll
Reduces the widths of all the columns below a given heading row cell. This is called recursively to account for any number of heading rows.Public Sub Table_ColsReduceAll(iRowNo As Integer, _
iColNo As Integer, _
iNoOfHeadingRows As Integer, _
sngAboveWidth As Single)
Const sPROCNAME As String = "Table_ColsReduceAll"
Dim icolumncounter%, sngdatarowsmaxwidth!, sngdatarowactual!, sngcellwidth!
Dim inoofmergedcolumns%, sngcombinedwidth!, sngDifference!, sngheadingwidth!
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
inoofmergedcolumns = Cell_HeadingIsItMerged(iRowNo, iColNo, iNoOfHeadingRows)
If inoofmergedcolumns > 0 Then 'cell is a merged heading
'for all the columns below this merged heading
For icolumncounter = 1 To (inoofmergedcolumns + 1) '1 merged column = 2 columns
Call Cell_MoveDown(iRowNo, iColNo)
Call Cell_MoveRightNo(iRowNo + 1, .Cells(1).ColumnIndex, icolumncounter - 1)
'moves across for all the rows below
Call Table_ColsReduceAll(iRowNo + 1, _
.Cells(1).ColumnIndex, _
iNoOfHeadingRows, _
0)
'returns the width of the total combined width below
'is this the last column below the merged heading
If icolumncounter = (inoofmergedcolumns + 1) Then
'get the width of the merged heading above
sngheadingwidth = Table_CellContentsWidth(Cell_GetContents, False)
sngcombinedwidth = _
Table_HeadingRowsReturnWidthBelow(iRowNo, _
iColNo, _
iNoOfHeadingRows)
'------------------------------ width of cells is less than the heading
If (sngheadingwidth > sngcombinedwidth) Then
sngDifference = (sngheadingwidth - sngcombinedwidth)
Call Table_ColsDistributeAmountBelow(iRowNo, _
iColNo, _
iNoOfHeadingRows, _
sngDifference)
End If
Else
End If
Next icolumncounter
' .Tables(1).Cell(iRowNo, iColNo).Select 'select the cell in question
Else 'heading is not merged above the cell below
'if the row is still part of the heading then continue
If (iRowNo < iNoOfHeadingRows) Then
sngheadingwidth = Table_CellContentsWidth(Cell_GetContents, False)
'width of current cell contents
If (sngAboveWidth > sngheadingwidth) Then sngheadingwidth = sngAboveWidth
'retain the maximum width above
Call Cell_MoveDown(iRowNo, iColNo) 'move to cell below
Call Table_ColsReduceAll(iRowNo + 1, _
.Cells(1).ColumnIndex, _
iNoOfHeadingRows, _
sngheadingwidth)
Else 'last row in the heading so finish
sngdatarowactual = .Tables(1).cell(iNoOfHeadingRows, iColNo).Width
sngdatarowsmaxwidth = Table_RowsDataReturnMaxWidth(iColNo, iNoOfHeadingRows)
'get the largest width from the data rows
If sngAboveWidth > sngdatarowsmaxwidth Then _
sngdatarowsmaxwidth = sngAboveWidth
'checks if there are none merged cells above with more text in
'the default width if the whole column is empty
If sngdatarowsmaxwidth = 0 Then sngdatarowsmaxwidth = sngDEF_COLBLANKWIDTH
sngDifference = sngdatarowsmaxwidth - sngdatarowactual
Call Table_RowsDataAdjustBelow(iColNo, _
iNoOfHeadingRows, _
sngdatarowsmaxwidth) 'adjust data rows
Call Table_HeadingRowsAdjustBelow(iColNo, _
iNoOfHeadingRows, _
sngDifference) 'adjust heading rows
'------------------------
End If
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
Cols_ReduceBlank
Defines the width of any blank columns found in the active table.Public Sub Table_ColsReduceBlank()
Const sPROCNAME As String = "Table_ColsReduceBlank"
Dim irowcounter%, icolumncounter%, itotalrowss%, itotalcolumns%, icountchars%
Dim bblankcol As Boolean
On Error GoTo AnError
With Selection
itotalcolumns = .Tables(1).Range.Columns.count
itotalrowss = .Tables(1).Range.Rows.count
For icolumncounter = 1 To itotalcolumns 'for every column in the table
bblankcol = True 'assign blank column toggle to true
For irowcounter = 1 To itotalrowss 'for every column in the table
If bblankcol = True Then
On Error Resume Next 'error checking cell may not exist
.Tables(1).cell(irowcounter, icolumncounter).Select 'select the cell
If .Characters.count > 1 Then bblankcol = False
End If
Next irowcounter
If bblankcol = True Then
.Tables(1).Columns(icolumncounter).SetWidth _
ColumnWidth:=sngDEF_COLBLANKWIDTH, RulerStyle:=wdAdjustNone
End If
Next icolumncounter
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"reduce the width of any blank columns to " & sngDEF_COLBLANKWIDTH)
End Sub
Cols_Select
Selects a given number of columns from the active table.Public Sub Cols_Select()
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cols_Select", msMODULENAME, 1, _
"")
End Sub
Cols_ShadeAlternate
Shades all the alternate columns to the right of the active cell.Public Sub Cols_ShadeAlternate(sTextureKey As String, _
sColourKey As String)
Dim icolumnnumber As Integer
Dim irownumber As Integer
Dim itotalcolumns As Integer
Dim itotalrowss As Integer
On Error GoTo AnError
With Selection
icolumnnumber = .Cells(1).ColumnIndex
irownumber = .Cells(1).RowIndex
itotalrowss = .Tables(1).Range.Rows.count
itotalcolumns = .Tables(1).Range.Columns.count
While icolumnnumber <= itotalcolumns
.Tables(1).cell(irownumber, icolumnnumber).Select
.MoveDown wdLine, itotalrowss - irownumber, wdExtend
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
If icolumnnumber < itotalcolumns Then
.Tables(1).cell(irownumber, icolumnnumber + 1).Select
.MoveDown wdLine, itotalrowss - irownumber, wdExtend
.Cells.Shading.Texture = wdTextureNone 'alternate no shading
End If
icolumnnumber = icolumnnumber + 2 'increment next column to shade
Wend
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cols_ShadeAlternate", msMODULENAME, 1, _
"shade the columns to the right of the active cell alternate colours")
End Sub
Cols_SplitMerged
Splits any merged cells found in a particular column.Public Sub Table_ColsSplitMerged(iColNo As Integer, _
iNoOfRows As Integer, _
iNoOfCols As Integer)
Const sPROCNAME As String = "Table_ColsSplitMerged"
Dim inoofcellstosplit%, irownumber%
On Error GoTo AnError
With Selection
inoofcellstosplit = iNoOfRows - Cell_RowsNoOf 'number of cells to split
irownumber = 1
Do Until (irownumber > iNoOfRows) 'for every row in the table
On Error GoTo MustSplitCell 'cell doesn't exist, we need to split the cell
.Tables(1).cell(irownumber, iColNo).Select 'select the cell
On Error GoTo 0 'turn error checking off
If iColNo < iNoOfCols Then 'for every row except the last one
.Tables(1).cell(irownumber, iColNo).Height = _
.Tables(1).cell(irownumber, iColNo + 1).Height
End If
irownumber = irownumber + 1 'increment the column number
Loop
MustSplitCell: 'when it splits cells, new cells have half the height of one being split
irownumber = irownumber - 1 'minimum height is ????
Do Until (inoofcellstosplit = 0)
.Tables(1).cell(irownumber, iColNo).Select
.Cells.Split NumRows:=1, NumColumns:=2 'split the cell
.MoveLeft wdCharacter, 1
.Cells.Width = Selection.Tables(1).cell(irownumber, iColNo + 1).Height
inoofcellstosplit = inoofcellstosplit - 1 'decrement the cells to split
irownumber = irownumber + 1 'increment the row number
Loop
.Tables(1).cell(irownumber, iColNo).Height = _
.Tables(1).cell(irownumber, iColNo + 1).Height
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
Cols_Width
Determines the total width of all the columns in the row of the active cell.Public Function Cols_Width() As Single
Dim sngcurrentwidth As Single
Dim itotalcolumns As Integer
Dim icolumnnumber As Integer
Dim irownumber As Integer
On Error GoTo AnError
With Selection
irownumber = .Cells(1).RowIndex
.SelectRow
itotalcolumns = .Columns.count
For icolumnnumber = 1 To itotalcolumns 'for every column in that row
.Tables(1).cell(irownumber, icolumnnumber).Select
sngcurrentwidth = sngcurrentwidth + .Cells.Width
'!!!!!!!!!!!!!! maybe default to zero if there is a problem !!
Next
End With
Cols_Width = sngcurrentwidth 'assign the total table width
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cols_Width", msMODULENAME, 1, _
"return the total width of the cells in the row of the active cell")
End Function
Cols_WidthShow
Displays a userfrom displaying the total width of all the columns in the row of the active cell Given in points so convert to centimeters.Public Sub Cols_WidthShow()
Dim sngtotalwidth&
On Error GoTo AnError
sngtotalwidth = Cols_Width 'calls procedure above to get the total width
' Call Frm_Inform("",
Call MsgBox( _
"Total width of the table in this row is: " & vbCrLf & _
sngtotalwidth & " points or " & _
Format(PointsToInches(sngtotalwidth), "0.00") & " inches")
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cols_WidthShow", msMODULENAME, 1, _
"display the total width of the table")
End Sub
ColsAlign
Aligns all the columns in the active table ???.Public Sub Table_ColsAlign(iNoOfHeadingRows As Integer, _
Optional sDirection As String = "LEFT")
Const sPROCNAME As String = "Table_ColsAlign"
On Error GoTo AnError
With Selection
.Tables(1).Select
.ParagraphFormat.Alignment = wdAlignParagraphRight
.Tables(1).cell(iNoOfHeadingRows, 1).Select
.SelectColumn
If sDirection = "LEFT" Then .ParagraphFormat.Alignment = wdAlignParagraphLeft
If sDirection = "RIGHT" Then .ParagraphFormat.Alignment = wdAlignParagraphRight
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
ColsAlignRight
Right aligns all the columns in the active table, except the first leftmost column that is left aligned.Public Sub Table_ColsAlignRight(iNoOfHeadingRows As Integer)
Const sPROCNAME As String = "Table_ColsAlignRight"
On Error GoTo AnError
With Selection
.Tables(1).Select
.ParagraphFormat.Alignment = wdAlignParagraphRight
.Tables(1).cell(iNoOfHeadingRows, 1).Select
.SelectColumn
.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"Right align all the columns while LEFT aligning the first one")
End Sub
ColSelect
Selects the whole column of a given cell. If no column or row is specified then the active cell is used.Public Sub Cell_ColSelect(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1)
Dim icolumnnumber As Integer
Dim itotalcolumns As Integer
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Selection.Tables(1).cell(iRowNo, iColNo).Column.Select
Else
Selection.SelectColumn
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_ColSelect", msMODULENAME, 1, _
"select the column of the active cell")
End Sub
ColsNoOf
Returns the total number of columns in the row of a given cell. If no column or row is specified then the active cell is used.Public Function Cell_ColsNoOf(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1) _
As Integer
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Selection.Tables(1).Rows(iRowNo).Select
Cell_ColsNoOf = Selection.Columns.count
Else
Selection.Tables(1).Rows(Selection.Cells(1).RowIndex).Select
Cell_ColsNoOf = Selection.Columns.count
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_ColsNoOf", msMODULENAME, 1, _
"return the total number of columns in the row of the active cell")
End Function
CurrentlyIn
Determines if you are currently in a table or not.Public Function Cell_CurrentlyIn(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
Optional ByVal bInformUser as Boolean = False) _
As Boolean
On Error GoTo AnError
If Selection.Information(wdWithInTable) = True And _
Selection.IsEndOfRowMark = False And _
Selection.Cells(1).RowIndex = iRowNo And _
Selection.Cells(1).ColumnIndex = iColNo Then
Cell_CurrentlyIn = True
Else
Cell_CurrentlyIn = False
End If
If gbDEBUG = False Then Exit Function
AnError:
Cell_CurrentlyIn = False
If bInformUser = True Then
Call Error_Handle("Cell_CurrentlyIn", msMODULENAME, 1, _
"determine if you are currently in a table or not")
End If
End Function
EmptyIsIt
Determines if a given cell in the active table is empty or not. If no column or row is specified then the active cell is used.Public Function Cell_EmptyIsIt(Optional ByVal iRowNo As Integer = -1, _
Optional ByVal iColNo As Integer = -1) _
As Boolean
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
If Selection.Tables(1).cell(iRowNo, iColNo).Range.Characters.count = 1 Then _
Cell_EmptyIsIt = True
Else
If Selection.Cells(1).Range.Characters.count = 1 Then _
Cell_EmptyIsIt = True
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_EmptyIsIt", msMODULENAME, 1, _
"determine if the cell (" & iColNo & "," & iRowNo & ") is empty or not")
End Function
FootNoteAdd
Adds a footnote to the active table.Public Sub Table_FootNoteAdd()
Const sPROCNAME As String = "Table_FootNoteAdd"
Dim sparagraphtext$
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
FootNoteChange
Changes the footnote of the active table.Public Sub Table_FootNoteChange()
Const sPROCNAME As String = "Table_FootNoteChange"
Dim sparagraphtext$
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
Format
Public Sub Table_Format(ByRef objDocument As Word.Document, _
ByVal objTable As Word.Table, _
ByVal sTableWidth As String, _
ByVal iNoOfHeadingRows As Integer, _
ByVal bAlternateRowShading As Boolean, _
Optional ByVal bIncludeBottomBorder As Boolean = False)
Const sPROCNAME As String = "Table_Format"
Dim ViewType As Word.WdViewType
Dim PaginationSetting As Boolean
On Error GoTo ErrorHandler
PaginationSetting = gApplicationWord.Options.Pagination
gApplicationWord.Options.Pagination = False
'ViewType = gApplicationWord.ActiveWindow.View.Type
'gApplicationWord.ActiveWindow.View.Type = Word.WdViewType.wdNormalView
Call modWordTables.Table_ClearAllFormatting(objTable)
Call modWordTables.Table_ApplySimpleRowFormatting(objTable, iNoOfHeadingRows, "Heading Row", False)
Call modWordTables.Table_ApplySimpleRowFormatting(objTable, iNoOfHeadingRows, "Standard Row", bAlternateRowShading)
'tweak table size, etc.
With objTable
.PreferredWidthType = Word.WdPreferredWidthType.wdPreferredWidthPoints
.Rows.LeftIndent = gApplicationWord.InchesToPoints(modWordTables.Table_SizeReturnIndent(sTableWidth))
.PreferredWidth = gApplicationWord.InchesToPoints(modWordTables.Table_SizeReturnWidth(objDocument, sTableWidth))
End With
If (bIncludeBottomBorder = True) Then
Call modWordTables.Table_BordersFormat_Row(objTable.Rows(objTable.Rows.Count), _
True, False, False, _
Word.WdLineStyle.wdLineStyleSingle, _
Word.WdLineWidth.wdLineWidth075pt, _
Word.WdColor.wdColorWhite)
End If
'reset Word options
Application.Options.Pagination = PaginationSetting
'gApplicationWord.ActiveWindow.View.Type = ViewType
Application.ScreenRefresh
'oApplication.UpdateStatusBar("Table Process Complete")
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
Application.Options.Pagination = PaginationSetting
Application.ActiveWindow.View.Type = ViewType
End Sub
FormatBasic
Public Sub Table_FormatBasic(ByRef oDocument As Word.Document, _
ByVal oTable As Word.Table, _
ByVal sStyleName_Heading As String, _
ByVal sStyleName_Rows As String)
Const sPROCNAME As String = "Table_FormatBasic"
Dim oRow As Word.Row
Dim oCell As Word.Cell
Dim iRowNo As Integer
On Error GoTo ErrorHandler
For iRowNo = 1 To oTable.Rows.Count
Set oRow = oTable.Rows(iRowNo)
If (iRowNo = 1) Then
oRow.Range.Style = sStyleName_Heading
For Each oCell In oRow.Cells
oCell.Range.Text = "header"
Next oCell
End If
If (iRowNo = 2) Then
oRow.Range.Style = sStyleName_Rows
For Each oCell In oRow.Cells
oCell.Range.Text = "text"
Next oCell
End If
If (iRowNo > 2) Then
oRow.Range.Style = sStyleName_Rows
End If
Next iRowNo
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
FormatExisting
Public Sub Table_FormatExisting(ByRef objDocument As Word.Document, _
ByVal sTableWidth As String, _
ByVal sStyleName_Heading As String, _
ByVal sStyleName_Rows As String, _
ByVal iNoOfCols As Integer, _
ByVal iNoOfRows As Integer, _
ByVal iNoOfHeadingRows As Integer, _
ByVal bAlternateRowShading As Boolean)
Const sPROCNAME As String = "Table_FormatExisting"
Dim objTable As Word.Table
On Error GoTo ErrorHandler
Set objTable = Application.Selection.Tables(1)
'if you are modifying a table you can only change the number of rows
'If (iNoOfCols > objTable.Columns.Count) Then
' 'need to add more columns
' objTable.Columns.Add(BeforeColumn:=objTable.Columns(objTable.Columns.Count)
'End If
'you can only add more rows - if you want to remove rows this must be done outside of this dialog
If (iNoOfRows > objTable.Rows.Count) Then
'need to add more rows
objTable.Cell(objTable.Rows.Count, 1).Select
Application.Selection.InsertRowsBelow (iNoOfRows - objTable.Rows.Count)
End If
Call modTables.Table_Format(objDocument, _
objTable, _
sTableWidth, _
sStyleName_Heading, _
sStyleName_Rows, _
iNoOfHeadingRows, _
bAlternateRowShading, False)
'Move insertion point to R1C1
Application.Selection.Collapse
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
FormatFromExcel
Public Sub Table_FormatFromExcel(ByRef objDocument As Word.Document, _
ByVal sTableWidth As String, _
ByVal sStyleName_Heading As String, _
ByVal sStyleName_Rows As String, _
ByVal iNoOfHeadingRows As Integer, _
ByVal bAlternateRowShading As Boolean)
Const sPROCNAME As String = "Table_FormatFromExcel"
Dim oCaptionRange As Word.Range
Dim oPastedRange As Word.Range
Dim objTable As Word.Table
Dim iNoOfCols As Integer
Dim iNoOfRows As Integer
On Error GoTo ErrorHandler
'Call ProgressBar_Invoke()
'Call ProgressBar_Update("Inserting data table from Excel...")
Application.Selection.TypeParagraph
If (sTableWidth = "Indented") Then
' oCaptionRange = modReferences.References_CaptionInsert(objDocument, "B-Table Title")
Else
' oCaptionRange = modReferences.References_CaptionInsert(objDocument, "B-Table Title. Full Width")
End If
oPastedRange = Application.Selection.Range
oPastedRange.Paste
If oPastedRange.Tables.Count = 0 Then
oCaptionRange.Delete
oPastedRange.Delete
Exit Sub
End If
If (modTables.Table_ExistsInDocument(objDocument) = True) Then
Set objTable = oPastedRange.Tables(1)
End If
iNoOfCols = objTable.Columns.Count
iNoOfRows = objTable.Rows.Count
objTable.Select
Call Table_Format(objDocument, _
objTable, _
sTableWidth, _
sStyleName_Heading, _
sStyleName_Rows, _
iNoOfHeadingRows, _
bAlternateRowShading, False)
'adds a source bit
With Application.Selection
.Tables(1).Select
.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
.TypeText "Source: [Source]."
' .HomeKey(Unit:=Word.WdUnits.wdLine, Extend:=Word.WdMovementType.wdExtend)
If (sTableWidth = "Indented") Then
.Style = objDocument.Styles("B-Source")
Else
.Style = objDocument.Styles("B-Source. Full Width")
End If
'.EndKey(Unit:=Word.WdUnits.wdLine, Extend:=Word.WdMovementType.wdMove)
End With
'gbProgressBar_Running = False
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
Set oCaptionRange = Nothing
Set oPastedRange = Nothing
End Sub
FormatParagraph
Public Sub Cell_FormatParagraph(ByVal objCells As Word.Cells, _
ByVal sStyleName As String, _
ByVal objParagraphAlignment As Word.WdParagraphAlignment, _
ByVal sngTopPadding As Single, _
ByVal sngBottomPadding As Single)
Const sPROCNAME As String = "Cell_FormatParagraph"
Dim objCell As Word.Cell
On Error GoTo ErrorHandler
For Each objCell In objCells
With objCell
.Range.Style = sStyleName
.Range.Paragraphs.Alignment = objParagraphAlignment
.TopPadding = sngTopPadding
.BottomPadding = sngBottomPadding
End With
Next objCell
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
GetContents
Returns the text/contents of a particular cell in the active table. If no column or row is specified then the active cell is used.Public Function Cell_GetContents(Optional ByVal iRowNo As Integer = -1, _
Optional ByVal iColNo As Integer = -1) _
As String
Dim scontents As String
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
scontents = Selection.Tables(1).cell(iRowNo, iColNo).Range.Text
Else
scontents = Selection.Cells(1).Range.Text
End If
Cell_GetContents = Left(scontents, Len(scontents) - 1)
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_GetContents", msMODULENAME, 1, _
"return the contents of the active cell")
End Function
HasVerticallyMergedCells
Public Function Table_HasVerticallyMergedCells(ByVal oTable As Word.Table) As Boolean
Const sPROCNAME As String = "Table_HasVerticallyMergedCells"
Dim oRow As Word.Row
On Error GoTo ErrorHandler
Set oRow = oTable.Rows(1)
Table_HasVerticallyMergedCells = False
Exit Function
ErrorHandler:
Table_HasVerticallyMergedCells = True
End Function
'**************************************************************************************
Function Table_HasVerticallyMergedCells(ByVal objTable As Word.Table) As Boolean
Const sPROCNAME As String = "Table_HasVerticallyMergedCells"
Dim objRow As Word.Row
On Error GoTo ErrorHandler
For Each objRow In objTable.Range.Rows
Table_HasVerticallyMergedCells = False
Next
Exit Function
ErrorHandler:
Table_HasVerticallyMergedCells = True
End Function
HeadingIsItMerged
Determines if a particular cell is actually a merged cell above multiple columns.Public Function Cell_HeadingIsItMerged(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
ByVal iNoOfHeadingRows As Integer) _
As Integer
Dim inoofmerged As Integer
Dim itotalcolumns As Integer
Dim icurrentcolumn As Integer
Dim ihighercolumnindex As Integer
Dim iheadingsrowscount As Integer
Dim icolumnnumber As Integer
On Error GoTo AnError
With Selection
If iRowNo < iNoOfHeadingRows Then
.Tables(1).Rows(iRowNo + 1).Select
itotalcolumns = .Columns.count 'number of columns in row below
inoofmerged = 0 'initialise number of merged cells to zero
Call Cell_MoveDown(iRowNo, iColNo) 'move to cell below
icolumnnumber = .Cells(1).ColumnIndex 'active cell column number
If Cell_RowLastIsItOn(.Cells(1).RowIndex, icolumnnumber) = False Then
Do
'check the number of columns in this row though (row below the cell in question)
Call Cell_MoveRight(iRowNo + 1, icolumnnumber)
icurrentcolumn = .Cells(1).ColumnIndex 'active cell column number
Call Cell_MoveUp(iRowNo + 1, icurrentcolumn)
ihighercolumnindex = .Cells(1).ColumnIndex 'active cell column number
If (ihighercolumnindex = iColNo) And _
(ihighercolumnindex < itotalcolumns) Then inoofmerged = inoofmerged + 1
'if it is the last cell in the row then it is not merged
.Tables(1).cell(iRowNo + 1, icurrentcolumn).Select
icolumnnumber = icolumnnumber + 1 'increment to move to next column along
Loop Until (ihighercolumnindex > iColNo) Or (icurrentcolumn = itotalcolumns)
Else
inoofmerged = 0
End If
Cell_HeadingIsItMerged = inoofmerged 'return number of merged headings
Else
Cell_HeadingIsItMerged = 0 'last heading row so obviously no merged headings
End If
' .Tables(1).cell(iRowNo, iColNo).Select 'select original cell
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_HeadingIsItMerged", msMODULENAME, 1, _
"determine if the cell (" & iColNo & "," & iRowNo & ") is a merged heading")
End Function
HeadingShareRHCell
Determines if a particular cell and the cell directly to its right share the same heading, ie have a merged cell above them.Public Function Cell_HeadingShareRHCell(ByVal iColNo As Integer, _
ByVal iRowlNo As Integer) _
As Boolean
Dim icurrentcolumnindex As Integer
Dim irhscolumnindex As Integer
On Error GoTo AnError
With Selection
Cell_HeadingShareRHCell = False
If iRowNo > 1 Then
.Tables(1).cell(iRowNo, iColNo).Select
Call Cell_MoveUpSpecific
icurrentcolumnindex = .Cells(1).ColumnIndex
If Cell_RowLastIsItOn(iRowNo, iColNo) = False Then
.Tables(1).cell(iRowNo, iColNo + 1).Select
Call Cell_MoveUpSpecific
irhscolumnindex = .Cells(1).ColumnIndex
If icurrentcolumnindex = irhscolumnindex Then _
Cell_HeadingShareRHCell = True
End If
End If
.Tables(1).cell(iRowNo, iColNo).Select 'select the original cell - NEED !
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_HeadingShareRHCell", msMODULENAME, 1, _
"determine if the cell (" & iColNo & "," & iRowNo & ") " & _
"and the cell directly to its right share a heading")
End Function
InOne
Determines if the cursor is currently in a table.Public Function Table_InOne(Optional ByVal objRange As Word.Range = Nothing, _
Optional ByVal bInformUser As Boolean = False) As Boolean
Const sPROCNAME As String = "Table_InOne"
On Error GoTo ErrorHandler
Dim breturn As Boolean
If objRange Is Nothing Then
objRange = Application.Selection.Range
End If
'breturn = CType(objRange.Information(Word.WdInformation.wdWithInTable), Boolean)
breturn = Table_InOneError(objRange)
If (breturn = False) And (bInformUser = True) Then
' Call modMessages.Table_NotInOne
End If
Table_InOne = breturn
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
InOneError
Public Function Table_InOneError(ByVal objRange As Word.Range) As Boolean
Const sPROCNAME As String = "Table_InOneError"
Dim inoofrows As Integer
On Error GoTo ErrorHandler
inoofrows = -1
inoofrows = objRange.Rows.Count
Table_InOneError = True
Exit Function
ErrorHandler:
Table_InOneError = False
End Function
MergedHorizontallyIsIt
Determines if a particular cell is a horizontally merged cell. If no column or row is specified then the active cell is used.Public Function Cell_MergedHorizontallyIsIt(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1) _
As Boolean
Dim itotalrowss As Integer
Dim inextrow As Integer
Dim inewcolindex As Integer
On Error GoTo AnError
Selection.Tables(1).cell(iRowNo, iColNo).Select
Cell_MergedHorizontallyIsIt = False
With Selection.Tables(1)
itotalrowss = .Rows.count
If (.Columns.count > 1 And itotalrowss > 1) Then
If iRowNo = itotalrowss Then inextrow = 1
If iRowNo < itotalrowss Then inextrow = iRowNo + 1
inewcolindex = .cell(inextrow, iColNo).ColumnIndex
Cell_MergedHorizontallyIsIt = inewcolindex <> iColNo
End If
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_MergedHorizontallyIsIt", msMODULENAME, 1, _
"determine if the cell (" & iColNo & "," & iRowNo & ") " & _
"is a horizontally merged cell")
End Function
MergedVerticallyIsIt
Determines if a particular cell is a vertically merged cell. If no column or row is specified then the active cell is used.Public Function Cell_MergedVerticallyIsIt(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1) _
As Boolean
Dim itotalrowss As Integer
Dim inextrow As Integer
Dim inewcolindex As Integer
On Error GoTo AnError
If iRowNo = -1 Then iRowNo = Selection.Cells(1).RowIndex
If iColNo = -1 Then iColNo = Selection.Cells(1).ColumnIndex
Selection.Tables(1).cell(iRowNo, iColNo).Select
Cell_MergedVerticallyIsIt = False
With Selection.Tables(1)
itotalrowss = .Rows.count
If (.Columns.count > 1 And itotalrowss > 1) Then
If iRowNo = itotalrowss Then inextrow = 1
If iRowNo < itotalrowss Then inextrow = iRowNo + 1
inewcolindex = .cell(inextrow, iColNo).ColumnIndex
Cell_MergedVerticallyIsIt = inewcolindex <> iColNo
End If
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_MergedVerticallyIsIt", msMODULENAME, 1, _
"determine if the cell (" & iRowNo & "," & iColNo & ") " & _
"is a vertically merged cell")
End Function
Messages_NotInOne
Public Sub Message_SelectionNotInTable()
Dim sMessage As String
sMessage = "The selection is not within a table."
Call MsgBox(sMessage, vbOKOnly + vbInformation, g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Not in Table")
Call Tracer_Add("MESSAGE", sMessage)
End Sub
MoveAbove
Moves the cursor to the line directly above the active table.Public Sub Table_MoveAbove()
Const sPROCNAME As String = "Table_MoveAbove"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"move the cursor to the line directly above the active table")
End Sub
MoveBelow
Moves the cursor to the line directly below the active table.Public Sub Table_MoveBelow()
Const sPROCNAME As String = "Table_MoveBelow"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"move the cursor to the line directly below the active table")
End Sub
MoveUpSpecific
Moves to the cell directly above the active cell.Public Sub Cell_MoveUpSpecific()
'could be redundant as we have left aligned the columns - BUT NEEDED IN formatting !!
On Error GoTo AnError
With Selection
If .Characters.count = 1 Then .MoveLeft wdCharacter, 1
If .Characters.count > 1 Then .Characters(1).Select
.MoveUp wdLine, 1
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_MoveUpSpecific", msMODULENAME, 1, _
"move to the cell above the active cell")
End Sub
NoOfLinesOfText
Public Function Table_NoOfLinesOfText(ByVal objTable As Word.Table) As Long
Const sPROCNAME As String = "Table_NoOfLinesOfText"
Dim irowcount As Integer
Dim ltotallines As Long
On Error GoTo ErrorHandler
If Not (objTable Is Nothing) Then
With objTable
For irowcount = 1 To .Rows.Count
ltotallines = ltotallines + .Rows(irowcount).Range.ComputeStatistics(Word.WdStatistic.wdStatisticLines)
Next irowcount
End With
End If
Table_NoOfLinesOfText = ltotallines
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
Table_NoOfLinesOfText = -1
End Function
ParaSelect
Selects the whole paragraph of the current selection. If no table number is specified then the active table is used.Public Sub Cell_ParaSelect(ByVal iColNo As Integer, _
ByVal iRowNo As Integer, _
Optional ByVal iTableNo As Integer = -1)
On Error GoTo AnError
If iTableNo = -1 Then iTableNo = 1
Selection.Tables(iTableNo).Cell(iRowNo, iColNo).Select
Selection.MoveLeft wdCharacter, 1
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_ParaSelect", msMODULENAME, 1, _
"select the paragraph in the cell")
End Sub
PositionOnPage
Public Sub Table_PositionOnPage(ByVal objTable As Word.Table, _
ByVal objFramePosition As Word.WdFramePosition)
Const sPROCNAME As String = "Table_PositionOnPage"
On Error GoTo ErrorHandler
Application.Selection.Tables(1).Select
With Application.Selection.Tables(1).Rows
.WrapAroundText = -1 'True
.HorizontalPosition = Word.WdTablePosition.wdTableLeft
.RelativeHorizontalPosition = Word.WdRelativeHorizontalPosition.wdRelativeHorizontalPositionColumn
.DistanceLeft = Application.InchesToPoints(0.13)
.DistanceRight = Application.InchesToPoints(0.13)
.VerticalPosition = objFramePosition
.RelativeVerticalPosition = Word.WdRelativeVerticalPosition.wdRelativeVerticalPositionMargin
.DistanceTop = Application.InchesToPoints(0)
.DistanceBottom = Application.InchesToPoints(0)
.AllowOverlap = 0 'False
End With
' Application.Selection.MoveLeft(Unit:=Word.WdUnits.wdWord, Count:=1)
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
ReferenceNumberUpdateAll
Updates all the reference numbers used in the titles above the tables in the active document.Public Sub Table_ReferenceNumberUpdateAll()
Const sPROCNAME As String = "Table_ReferenceNumberUpdateAll"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
Riows_ParaFormat
Formats the paragraph spacing of all the rows in the active table.Public Sub Table_RowsParaFormat(sngHeightOfRows As Single)
Const sPROCNAME As String = "Table_RowsParaFormat"
On Error GoTo AnError
With Selection
.Tables(1).Select
.Cells.SetHeight RowHeight:=sngHeightOfRows, HeightRule:=wdRowHeightAtLeast
.Cells.VerticalAlignment = wdAlignVerticalCenter 'center in rows
Call Para_Format(0, 0, "A") 'formats the paragraph spacing
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"adjust the paragraph formatting for the table" & vbCrLf & _
"Making the row height at least " & sngHeightOfRows)
End Sub
Row_BlankIsIt
Determines if a particular row in the active table is blank, ie contains no data.Public Function Row_BlankIsIt(Optional iRowNo As Integer = -1) As Boolean
Const sPROCNAME As String = "Row_BlankIsIt"
Dim itotalrowss%, icolumnnumber%, bblankrow As Boolean
On Error GoTo AnError
With Selection
Selection.Tables(1).Range.Rows(iRowNo).Select
bblankrow = True
For icolumnnumber = 1 To Selection.Tables(1).Range.Columns.count
.Tables(1).cell(iRowNo, icolumnnumber).Select
If Selection.Characters.count > 1 Then
bblankrow = False
Exit For
End If
Next icolumnnumber
End With
Row_BlankIsIt = bblankrow
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"determine if row " & iRowNo & " is blank")
End Function
Row_BorderAdd
Adds a border to a particular row in the active table.Public Sub Row_BorderAdd(Optional iRowNo As Integer = -1, _
Optional sDirection As String = "TOP", _
Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Row_BorderAdd"
On Error GoTo AnError
With Selection
.Tables(1).Range.Rows(iRowNo).Select
If sDirection = "TOP" Then
.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderTop).ColorIndex = Return_ShadingColour(sColourKey)
End If
If sDirection = "BOTTOM" Then
.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderBottom).ColorIndex = Return_ShadingColour(sColourKey)
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"add a border to the " & sDirection & " of row " & iRowNo)
End Sub
Row_BorderHas
Determines if a particular row in the active table has either a Top or Bottom border.Public Function Row_BorderHas(Optional iRowNo As Integer = -1, _
Optional sDirection As String = "TOP") As Boolean
Const sPROCNAME As String = "Row_BorderHas"
Dim ilinestyle%
On Error GoTo AnError
Selection.Tables(1).Range.Rows(iRowNo).Select
If sDirection = "TOP" Then ilinestyle = Selection.Borders(wdBorderTop).LineStyle
If sDirection = "BOTTOM" Then ilinestyle = Selection.Borders(wdBorderBottom).LineStyle
If ilinestyle <> 0 Then Row_BorderHas = True
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"determine if there is a border on the " & sDirection & " of row " & iRowNo)
End Function
Row_BordersClearAll
Removes all the borders from the active table.Public Sub Row_BordersClearAll(Optional iRowNo As Integer = -1)
Const sPROCNAME As String = "Row_BordersClearAll"
On Error GoTo AnError
Selection.Tables(1).Range.Rows(iRowNo).Select
Selection.Borders.Enable = False
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"clear all the borders from row " & iRowNo)
End Sub
Row_EndMarkerSelected
Determines if the end of row marker has been reached.Public Sub Row_EndMarkerSelected()
Const sPROCNAME As String = "Row_EndMarkerSelected"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"")
End Sub
Row_FontColour
Defines the colour of the font used for a particular row in the active table.Public Sub Row_FontColour(Optional iRowNo As Integer = -1, _
Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Row_FontColour"
Dim irownumber As Integer
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
End Sub
Row_HeightDecrease
Decreases the height of aparticular row in the active table.Public Sub Row_HeightDecrease(Optional iDecreaseAmount As Integer = 20, _
Optional iRowNo As Integer = -1)
Const sPROCNAME As String = "Row_HeightDecrease"
Dim lnewheight&
On Error GoTo AnError
With Selection
.SelectRow
lnewheight = .Rows.Height - iDecreaseAmount
.Rows.SetHeight RowHeight:=lnewheight, HeightRule:=wdRowHeightAtLeast
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"decrease the height of row " & iRowNo & " by " & iDecreaseAmount)
End Sub
Row_HeightIncrease
Increases the height of a particular row in the active table.Public Sub Row_HeightIncrease(Optional iIncreaseAmount As Integer = 20, _
Optional iRowNo As Integer = -1)
Const sPROCNAME As String = "Row_HeightIncrease"
Dim lnewheight&
On Error GoTo AnError
With Selection
.SelectRow
lnewheight = .Rows.Height + iIncreaseAmount
.Rows.SetHeight RowHeight:=lnewheight, HeightRule:=wdRowHeightAtLeast
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"increase the height of row " & iRowNo & " by " & iIncreaseAmount)
End Sub
Row_NumberOfColumns
Returns the total number of cells in particular row in the active table.Public Function Row_CellsNoOf(Optional iRowNo As Integer = -1) As Integer
Const sPROCNAME As String = "Row_CellsNoOf"
Dim inoofcells%, iColNo%
On Error Goto AnError
With Selection
iColNo = .Tables(1).Columns.count
Do While (Cell_Exists(iRowNo, iColNo) = False)
iColNo = iColNo - 1
Loop
End With
Row_CellsNoOf = iColNo
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the total number of cells in the row " & iRowNo)
End Function
Row_Shade
Shade a row in the active table.Public Sub Row_Shade(Optional sTextureKey As String = "25P", _
Optional sColourKey As String = "DB", _
Optional iRowNo As Integer = -1)
Const sPROCNAME As String = "Row_Shade"
Dim irownumber%
On Error GoTo AnError
With Selection
If iRowNo > -1 Then .Tables(1).cell(iRowNo, 1).Select
irownumber = .Cells(1).RowIndex
.Tables(1).Rows(irownumber).Select
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"shade row number " & Selection.Cells(1).RowIndex)
End Sub
'****************************************************************************************
Public Sub Table_ShadingFormat_Row(ByVal objRow As Word.Row, _
ByVal enBackgroundPatternRGB As Word.WdColor, _
Optional ByVal enForegroundPatternRGB As Word.WdColor = Word.WdColor.wdColorAutomatic, _
Optional ByVal objTexture As Word.WdTextureIndex = Word.WdTextureIndex.wdTextureNone)
Const sPROCNAME As String = "Table_ShadingFormat_Row"
On Error GoTo ErrorHandler
With objRow.Shading
.Texture = objTexture
.ForegroundPatternColor = enForegroundPatternRGB
.BackgroundPatternColor = enBackgroundPatternRGB
End With
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Row_ShadeFromCell
Shades all the cells in a particular row to the right of the active cell.Public Sub Row_ShadeFromCell(sTextureKey As String, _
sColourKey As String, _
Optional iRowNo As Integer = -1, _
Optional iColNo As Integer = -1)
Const sPROCNAME As String = "Row_ShadeFromCell"
Dim icolumnnumber%, itotalcolumns%
On Error GoTo AnError
With Selection
If (iRowNo > -1) And (iColNo > -1) Then .Tables(1).cell(iRowNo, iColNo).Select
icolumnnumber = .Cells(1).ColumnIndex
itotalcolumns = .Tables(1).Range.Columns.count
.MoveRight wdCharacter, itotalcolumns - icolumnnumber + 1, wdExtend
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"shade the row from the active cell along")
End Sub
Row_ShadingClear
Removes all the shading from a row in the active table.Public Sub Row_ShadingClear(Optional iRowNo As Integer = -1)
Const sPROCNAME As String = "Row_ShadingClear"
On Error GoTo AnError
With Selection
If iRowNo > -1 Then .Tables(1).cell(iRowNo, 1).Select
.Tables(1).Rows(.Cells(1).RowIndex).Select
.Cells.Shading.Texture = wdTextureNone
.Cells.Shading.ForegroundPatternColorIndex = wdNoHighlight
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"clear all the shading from row number " & Selection.Cells(1).RowIndex)
End Sub
RowFirstIsItOn
Determines if a particular cell is the first row of the active table.Public Function Cell_RowFirstIsItOn(ByVal iColNo As Integer, _
ByVal iRowNo As Integer) _
As Boolean
On Error GoTo AnError
Selection.Tables(1).cell(iRowNo, iColNo).Select
If iRowNo > 1 Then Cell_RowFirstIsItOn = False
If iRowNo = 1 Then Cell_RowFirstIsItOn = True
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_RowFirstIsItOn", msMODULENAME, 1, _
"determine if the cell is in the first row of the table")
End Function
RowIndex
Returns the index number of the currently active cell.Public Function Cell_RowIndex() As Integer
On Error GoTo AnError
Cell_RowIndex = Selection.Cells(1).RowIndex
If gbDEBUG = False Then Exit Function
AnError:
Selection.Cells(1).Select
Call Error_Handle("Cell_RowIndex", msMODULENAME, 1, _
"return the row index number of the active cell")
End Function
RowLastIsItOn
Determines if a particular cell is on the last row of the active table.Public Function Cell_RowLastIsItOn(ByVal iColNo As Integer, _
ByVal iRowNo As Integer) _
As Boolean
Dim itotalcolumns As Integer
On Error GoTo AnError
With Selection
.Tables(1).Rows(iRowNo).Select
itotalcolumns = .Columns.count
If iColNo < itotalcolumns Then Cell_RowLastIsItOn = False
If iColNo = itotalcolumns Then Cell_RowLastIsItOn = True
.Tables(1).cell(iRowNo, iColNo).Select ' NEED !!
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_RowLastIsItOn", msMODULENAME, 1, _
"determine if the cell is in the last row of the table")
End Function
Rows_Bold
Defines the text in a block of rows to be bold.Public Sub Rows_Bold(iRowFirst As Integer, _
iRowLast As Integer)
Const sPROCNAME As String = "Rows_Bold"
Dim irownumber%
On Error GoTo AnError
With Selection
For irownumber = iRowFirst To iRowLast
.Tables(1).cell(irownumber, 1).Select
Selection.SelectRow
.Font.Bold = True
Next irownumber
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"bold the rows between rows " & iRowFirst & " and " & iRowLast)
End Sub
Rows_DataAdjustBelow
Adjusts the width of all the cells in a particular column belwo a given heading row.Public Sub Table_RowsDataAdjustBelow(iColNo As Integer, _
iNoOfHeadingRows As Integer, _
sngNewCellWidth As Single)
Const sPROCNAME As String = "Table_RowsDataAdjustBelow"
Dim itotalrowss%
On Error GoTo AnError
With Selection
itotalrowss = .Tables(1).Rows.count
.Tables(1).cell(iNoOfHeadingRows, iColNo).Select 'select given cell
.MoveDown wdLine, itotalrowss - iNoOfHeadingRows, wdExtend 'extend all data rows
'************** added as a precaution !!!! sometimes selects 2 columns or more !!
Do While .Columns.count > 1
.MoveLeft wdCharacter, 1, wdExtend
Loop
'**************
.Cells.Width = sngNewCellWidth 'change to the new cell width
Do While .Cells(1).RowIndex > 1
Call Cell_MoveUp(.Cells(1).RowIndex, .Cells(1).ColumnIndex)
Loop
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"adjust the width of all the cells in the column " & iColNo & _
" below the heading rows")
End Sub
Rows_DataReturnMaxWidth
Determines the maximum width of all the cells in a particular column below the heading row.Public Function Table_RowsDataReturnMaxWidth(iColNo As Integer, _
iNoOfHeadingRows As Integer) As Single
Const sPROCNAME As String = "Table_RowsDataReturnMaxWidth"
Dim itotalrowss%, irowcounter%, sngcellwidth!, sngmaxcellwidth!
On Error GoTo AnError
With Selection
itotalrowss = .Tables(1).Rows.count
For irowcounter = iNoOfHeadingRows To itotalrowss 'for all the data rows
.Tables(1).cell(irowcounter, iColNo).Select
If .Characters.count > 1 Then 'if the cell is not empty
sngcellwidth = Word_Width(Cell_GetContents, False) 'get cell width
If sngcellwidth > sngmaxcellwidth Then sngmaxcellwidth = sngcellwidth
End If
Next irowcounter
Table_RowsDataReturnMaxWidth = sngmaxcellwidth 'assign maximum width
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the maximum width of all the cells in column " & iColNo & _
" below the heading rows")
End Function
Rows_DeleteBlank
Deletes all the blank rows from the active table Note that the rows are deleted in reverse order !.Public Sub Table_RowsBlankDelete()
Const sPROCNAME As String = "Table_RowsBlankDelete"
Dim irownumber As Integer, itotalrowss As Integer
On Error GoTo AnError
With Selection
itotalrowss = Selection.Tables(1).Range.Rows.count
For irownumber = itotalrowss To 1 Step -1
If Row_BlankIsIt(irownumber) = True Then
.Tables(1).Rows(irownumber).Delete
End If
Next irownumber
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"delete the blank rows in the table")
End Sub
Rows_Format
Public Sub Rows_Format(iTableNo As Integer, _
iRowFirst As Integer, _
iRowLast As Integer, _
iNoOfCols As Integer)
On Error Goto AnError
With ActiveDocument.Tables(iTableNo).Cell(iRowLast, 1)
.Shading.Texture = wdTextureNone
.Shading.ForegroundPatternColor = wdColorAutomatic
.Shading.BackgroundPatternColor = wdColorTurquoise
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Rows_Format", msMODULENAME, 1, _
"select the rows in the table")
End Sub
Rows_FormatBlank
Applies the customised formatting to all the blank rows in the active table.Public Sub Table_RowsBlankFormat(Optional sngHeightOfRows As Single = _
sngDEF_ROWBLANKHEIGHT)
Const sPROCNAME As String = "Table_RowsBlankFormat"
Dim irownumber%, icolumnnumber%, itotalrowss%, itotalcolumns%, icountchars%
Dim bblankrow As Boolean
On Error GoTo AnError
With Selection
itotalrowss = Selection.Tables(1).Range.Rows.count
For irownumber = 1 To itotalrowss
bblankrow = True 'assign blank row toggle to true
itotalcolumns = Selection.Tables(1).Rows(irownumber).Range.Columns.count
'there may be a different number of columns in each row
For icolumnnumber = 1 To itotalcolumns
'----------------BUT THIS IS ALWAYS TRUE !!!!!
If bblankrow = True Then
On Error Resume Next 'error checking cell may not exist
.Tables(1).cell(irownumber, icolumnnumber).Select 'select cell
If .Characters.count > 1 Then bblankrow = False
End If
Next
Next
If bblankrow = True Then 'if it is a blank row then reduce the row height
.Tables(1).Rows(irownumber).SetHeight RowHeight:=sngHeightOfRows, _
HeightRule:=wdRowHeightExactly
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"format all the blank rows in the table")
End Sub
Rows_HeadingAdjustBelow
Defines the width of all the cells in a particular column below the given heading row.Public Sub Table_RowsHeadingAdjustBelow(iColNo As Integer, _
iNoOfHeadingRows As Integer, _
sngDifference As Single)
Const sPROCNAME As String = "Table_RowsHeadingAdjustBelow"
Dim irowcounter%
On Error GoTo AnError
With Selection
.Tables(1).cell(iNoOfHeadingRows, iColNo).Select 'select the heading cell
For irowcounter = 1 To (iNoOfHeadingRows - 1) 'for all the heading rows
Call Cell_MoveUp(Cell_RowIndex, Cell_ColIndex)
.Cells.Width = .Cells.Width + sngDifference
Next irowcounter
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"increase the width of all the cells in column " & iColNo & _
" below the " & iNoOfHeadingRows & " heading rows to " & sngDifference)
End Sub
Rows_HeadingCenterMerged
Centers any cells that are merged in the heading rows.Public Sub Table_RowsHeadingCenterMerged(ByVal iNoOfHeadingRows As Integer)
Const sPROCNAME As String = "Table_RowsHeadingCenterMerged"
Dim itotalcolumns%, icolumnnumber%, inoofmerged%, ihighercolumnindex%
On Error GoTo AnError
With Selection
While iNoOfHeadingRows > 1
inoofmerged = 0
.Tables(1).Rows(iNoOfHeadingRows).Select
itotalcolumns = .Columns.count
For icolumnnumber = 1 To itotalcolumns
.Tables(1).cell(iNoOfHeadingRows, icolumnnumber).Select
.MoveUp wdLine, 1 'move back into table
If .IsEndOfRowMark Then .MoveLeft Unit:=wdCharacter, count:=1
ihighercolumnindex = .Cells(1).ColumnIndex
If icolumnnumber > (ihighercolumnindex + inoofmerged) Then
.MoveUp wdLine, iNoOfHeadingRows - 2, wdExtend
'to allow for a merged heading and then corresponding merged above it
.ParagraphFormat.Alignment = wdAlignParagraphCenter
inoofmerged = inoofmerged + 1
End If
Next icolumnnumber
iNoOfHeadingRows = iNoOfHeadingRows - 1
Wend
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"center any cells that are merged cells in the heading rows")
End Sub
Rows_HeadingCheckMinimum
Determines if the number of heading rows is sufficient for the active table.Public Function Table_RowsHeadingCheckMinimum(iNoOfHeadingRows As Integer) As Boolean
Const sPROCNAME As String = "Table_RowsHeadingCheckMinimum"
Dim sMessage$
On Error GoTo AnError
If iNoOfHeadingRows = 1 Then sMessage = iNoOfHeadingRows & " heading row !!"
If iNoOfHeadingRows <> 1 Then sMessage = iNoOfHeadingRows & " heading rows !!"
If Table_HeadingRowsMinimum > iNoOfHeadingRows Then
Call Frm_Inform("", "Unable to format the table with " & sMessage & vbCrLf & _
"You have merged cells so you must include column headings", True)
Table_HeadingRowsCheckMinimum = False
Else
Table_HeadingRowsCheckMinimum = True
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"confirm if the number of heading rows is adequate for the table")
End Function
Rows_HeadingColBold
Bolds the heading rows of the active table and / or the first leftmost column.Public Sub Table_RowsHeadingColBold(ByVal iNoOfHeadingRows As Integer, _
Optional bBoldLeftCol As Boolean = False)
Const sPROCNAME As String = "Table_RowsHeadingColBold"
On Error GoTo AnError
With Selection
While iNoOfHeadingRows > 0 'maybe do it cell by cell ???
.Tables(1).Rows(iNoOfHeadingRows).Select
.Font.Bold = True 'bolds the selection
.Cells.VerticalAlignment = wdCellAlignVerticalBottom 'at the bottom
iNoOfHeadingRows = iNoOfHeadingRows - 1 'decrement the number of heading rows
Wend
If bBoldLeftCol = True Then
.Tables(1).cell(iNoOfHeadingRows + 1, 1).Select
.SelectColumn 'selects the whole column
.Font.Bold = True
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"bold the heading rows and / or teh first column as well !")
End Sub
Rows_HeadingHowMany
Determines the number of heading rows used in a table by checking the borders.Public Function Table_RowsHeadingHowMany() As Integer
Const sPROCNAME As String = "Table_RowsHeadingHowMany"
Dim irownumber% 'assumes it has been formatted !!!
On Error GoTo AnError
irownumber = 1
Selection.Tables(1).cell(1, 1).Select 'select the first cell
While Selection.Borders(wdBorderBottom).LineStyle <> Options.DefaultBorderLineStyle
irownumber = irownumber + 1 'increment the number of rows
Selection.Tables(1).cell(irownumber, 1).Select
Wend
Table_HeadingRowsHowMany = irownumber
'maybe do some really obscure formatting !
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"determine the number of heading rows from the borders on the table")
End Function
Rows_HeadingMinimum
Returns the minimum number of heading rows for the active table used by checking for any merged cells.Public Function Table_RowsHeadingMinimum() As Integer
Const sPROCNAME As String = "Table_RowsHeadingMinimum"
Dim imaxnoofcols%, iRowNo%
With Selection
iRowNo = .Tables(1).Range.Rows.count
imaxnoofcols = .Tables(1).Rows(iRowNo).Range.Columns.count
Do Until (iRowNo = 0)
If (Row_CellsNoOf(iRowNo) < imaxnoofcols) Then
iRowNo = iRowNo + 1
Exit Do
End If
If iRowNo = 1 Then Exit Do
If iRowNo > 1 Then iRowNo = iRowNo - 1
Loop
Table_HeadingRowsMinimum = iRowNo
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the minimum number of heading rows required for the table")
End Function
Rows_HeadingReturnWidthBelow
Returns the total width of all the cells below a given cell.Public Function Table_RowsHeadingReturnWidthBelow(iRowNo As Integer, _
iColNo As Integer, _
iNoOfHeadingRows As Integer) As Single
Const sPROCNAME As String = "Table_RowsHeadingReturnWidthBelow"
Dim istartcolumn%, icolumncounter%, sngcombinedwidth!, inoofmergedcolumns%
On Error GoTo AnError
With Selection
.Tables(1).cell(iRowNo, iColNo).Select
inoofmergedcolumns = Cell_HeadingIsItMerged(iRowNo, iColNo, iNoOfHeadingRows)
istartcolumn = iColNo
sngcombinedwidth = 0 'set the initial combined width to 0
For icolumncounter = 1 To (inoofmergedcolumns + 1) 'for all columne below
Call Cell_MoveDown(iRowNo, iColNo) 'move to cell below
Call Cell_MoveRightNo(iRowNo + 1, Cell_ColIndex, icolumncounter - 1)
sngcombinedwidth = sngcombinedwidth + .Cells(1).Width
Next icolumncounter
Table_HeadingRowsReturnWidthBelow = sngcombinedwidth 'assign the combined width
End With
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the total width of all the cells below the cell in heading rows")
End Function
Rows_HeadingsMergeFromExcel
Merges all the appropriate heading row cells when a table is pasted from Excel.Public Sub Table_RowsHeadingsMergeFromExcel(ByVal iNoOfHeadingRows As Integer)
Const sPROCNAME As String = "Table_RowsHeadingsMergeFromExcel"
Dim itotalcolumns%, irowcolumns%, icolumnnumber%
On Error GoTo AnError
With Selection
If (.Tables(1).cell(1, 1).Borders(wdBorderTop).LineStyle <> wdLineStyleNone) Then
While iNoOfHeadingRows > 1
itotalcolumns = .Tables(1).Rows(iNoOfHeadingRows - 1).Range.Columns.count
.Tables(1).cell(iNoOfHeadingRows - 1, 1).Select
For icolumnnumber = 1 To (itotalcolumns - 1)
.MoveRight wdCell, 1
.Cells(1).Select
If .Cells(1).Borders(wdBorderLeft).LineStyle = wdLineStyleNone Then
.MoveLeft wdCharacter, 2, wdExtend
.Cells.Merge
End If
Next icolumnnumber
iNoOfHeadingRows = iNoOfHeadingRows - 1
Wend
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"merge any necessary cells in the table pasted directly from Excel")
End Sub
Rows_HeightShow
Displays a userform displaying the total height of all the cells in the column of the active cell.Public Sub Rows_HeightShow()
Const sPROCNAME As String = "Rows_HeightShow"
Dim sngtotalheight!
On Error GoTo AnError
sngtotalheight = Rows_Height(True)
If sngtotalheight > 0 Then _
Call Frm_Inform("", "Total height of the table in this column is:" & vbCrLf & _
sngtotalheight & " points or " & _
Format(PointsToCentimeters(sngtotalheight), "0.00") & " cms")
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"display the total height of the table")
End Sub
Rows_Insert
Dispalys a userform to obtain the number of rows to insert below the active cell.Public Sub Rows_Insert()
Const sPROCNAME As String = "Rows_Insert"
Dim itotalrowss%
On Error GoTo AnError
Call Frm_GetInput("", "Number of rows to insert: ", "Insert")
itotalrowss = CInt(gsResponse)
If IsNumeric(itotalrowss) And itotalrowss > 0 Then 'check its a valid number entry
Call Rows_InsertNo(itotalrowss) 'calls procedure above - insert rows
Else
Call Frm_Inform("", "Incorrect number of rows!")
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"insert " & itotalrowss & " rows into the table")
End Sub
Rows_InsertNo
Inserts a certain number of rows below the active cell.Public Sub Rows_InsertNo(iNoOfRows As Integer)
Const sPROCNAME As String = "Rows_InsertNo"
On Error GoTo AnError
While iNoOfRows > 0
Selection.InsertRows 1
iNoOfRows = iNoOfRows - 1 'reduce number of rows to insert
Wend
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"insert " & iNoOfRows & " rows into the table")
End Sub
Rows_NoOfShow
Displays a userform to display the total number of rows in the active table.Public Sub Rows_NoOfShow()
Const sPROCNAME As String = "Rows_NoOfShow"
Dim itotalrowss%
On Error GoTo AnError
itotalrowss = Selection.Tables(1).Range.Rows.count
' Call Frm_Inform("",
Call MsgBox( _
"Total number of rows in this table is: " & itotalrowss)
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"display the total number of rows in the column of the active cell")
End Sub
Rows_Select
Selects a contiguous block of rows in a given table.Public Sub Rows_Select(iTableNo As Integer, _
iRowFirst As Integer, _
iRowLast As Integer, _
iNoOfCols As Integer)
Const sPROCNAME As String = "Rows_Insert"
On Error Goto AnError
ActiveDocument.Tables(iTableNo).Cell(iRowLast, 1).Select
Selection.Moveup wdLine, iRowLast - iRowFirst, wdExtend
Selection.MoveRight wdCharacter, iNoOfCols, wdExtend
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"select the rows in the table")
End Sub
Rows_ShadeAlternate
Shades all the alternate rows below the active cell.Public Sub Rows_ShadeAlternate(Optional sTextureKey As String = "25P", _
Optional sColourKey As String = "DB", _
Optional iRowNo As Integer = -1, _
Optional iColNo As Integer = -1)
Const sPROCNAME As String = "Rows_ShadeAlternate"
Dim irownumber%, itotalrowss%, snewrange$
On Error GoTo AnError
With Selection
If (iRowNo > -1) And (iColNo > -1) Then .Tables(1).cell(iRowNo, iColNo).Select
irownumber = .Cells(1).RowIndex
itotalrowss = .Tables(1).Range.Rows.count
While irownumber <= itotalrowss
.Tables(1).Range.Rows(irownumber).Select
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
If irownumber < itotalrowss Then 'if it is not the last row
.Tables(1).Range.Rows(irownumber + 1).Select
.Cells.Shading.Texture = wdTextureNone 'alternate no shading
End If
irownumber = irownumber + 2 'increments by 2 for alternate
Wend
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"shade the rows below the active cell alternate columns")
End Sub
Rows_SplitMerged
Splits up any merged cells in a given row in the active table.Public Sub Table_RowsSplitMerged(iRowNo As Integer, _
iNoOfCols As Integer, _
iNoOfRows As Integer)
Const sPROCNAME As String = "Table_RowsSplitMerged"
Dim inoofcellstosplit%, icolumnnumber%
On Error GoTo AnError
With Selection
inoofcellstosplit = iNoOfCols - Cell_ColsNoOf 'number of cells to split
icolumnnumber = 1
Do Until (icolumnnumber > iNoOfCols) 'for every column in the table
On Error GoTo MustSplitCell 'cell doesn't exist, need to split the cell
.Tables(1).cell(iRowNo, icolumnnumber).Select 'select the cell
On Error GoTo 0 'turn error checking off
If iRowNo < iNoOfRows Then 'for every row except the last one
.Tables(1).cell(iRowNo, icolumnnumber).SetWidth ColumnWidth:= _
.Tables(1).cell(iRowNo + 1, icolumnnumber).Width, RulerStyle:=wdAdjustNone
End If
icolumnnumber = icolumnnumber + 1 'increment the column number
Loop
MustSplitCell: 'when it splits cells, new cells have half the width of one being split
icolumnnumber = icolumnnumber - 1 'go back a column 'minimum width is 0.42
Do Until (inoofcellstosplit = 0)
.Tables(1).cell(iRowNo, icolumnnumber).Select 'selects the cell
.Cells.Split NumRows:=1, NumColumns:=2 'split the cell in 2
.MoveLeft wdCharacter, 1 'moves left, to first split cell
.Cells.SetWidth ColumnWidth:= _
.Tables(1).cell(iRowNo + 1, icolumnnumber).Width, RulerStyle:=wdAdjustNone
inoofcellstosplit = inoofcellstosplit - 1 'decrement the cells to split
icolumnnumber = icolumnnumber + 1 'move to next column
Loop
'--------------THESE ARE THE SAME ?????????????????
If iRowNo < iNoOfRows Then
.Tables(1).cell(iRowNo, icolumnnumber).Width = _
.Tables(1).cell(iRowNo + 1, icolumnnumber).Width
Else
.Tables(1).cell(iRowNo, icolumnnumber).Width = _
.Tables(1).cell(iRowNo - 1, icolumnnumber).Width
End If
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"split all the merged rows in a table")
End Sub
Rows_TotalColumnHeight
Determines the total height of all the cells in the column of the active cell.Public Function Rows_Height(bInformUser As Boolean, _
Optional sngDefaultAtLeastHeight As Single = 12) As Single
Const sPROCNAME As String = "Rows_Height"
Dim sngcurrentheight!, irownumber%, iheadingrowsmin%, icolumnnumber%
On Error GoTo AnError
With Selection
Do While .Cells(1).RowIndex > 1
Call Cell_MoveUpSpecific
Loop
icolumnnumber = .Cells(1).ColumnIndex
iheadingrowsmin = Table_HeadingRowsMinimum
For irownumber = 1 To .Tables(1).Rows.count
If .Cells.Height = wdUndefined Then 'checks for undefined row height
Call Frm_Choice("", "Row height in cell (" & irownumber & "," & icolumnnumber & _
") " & "is automatic. " & vbCrLf & "Would you like to change the " & _
"height to ""at least"" " & sngDefaultAtLeastHeight & "")
If gbChoice = True Then
.Tables(1).cell(irownumber, icolumnnumber).SetHeight _
RowHeight:=sngDEF_ROWATLEASTHEIGHT, _
HeightRule:=wdRowHeightAtLeast
sngcurrentheight = sngcurrentheight + sngDefaultAtLeastHeight
End If
If gbChoice = False Then
Rows_Height = 0
Exit Function
End If
Else
sngcurrentheight = sngcurrentheight + .Cells.Height
End If
If irownumber < .Tables(1).Rows.count Then _
Call Cell_MoveDown(irownumber, .Cells(1).ColumnIndex, _
(irownumber <= iheadingrowsmin))
Next
End With
Rows_Height = sngcurrentheight 'assign the total table height
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"return the total height of the cells in the column of the active cell")
End Function
RowSelect
Selects the whole row containing a particular cell.Public Sub Cell_RowSelect(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1)
Dim icolumnnumber As Integer
Dim itotalcolumns As Integer
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Selection.Tables(1).cell(iRowNo, iColNo).Row.Select
Else
Selection.SelectRow
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Cell_RowSelect", msMODULENAME, 1, _
"select the row of the active cell")
End Sub
RowsFormat
Formats all the rows in the active table.Public Sub Table_RowsFormat(sngHeightOfRows As Single)
Const sPROCNAME As String = "Table_RowsFormat"
On Error GoTo AnError
With Selection
.Tables(1).Select 'select the whole table
.style = sDEF_STYLE_TABLETEXT
' Call Text_Format("UL", 8, 1, False) 'formats the text
Call Table_RowsParaFormat(sngHeightOfRows)
.Rows.SpaceBetweenColumns = 0 'consistent column space
Call Sel_IndentRight(0) 'paragraph right indent
Call Sel_IndentLeft(0) 'paragraph left indent
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"format all the rows in the table")
End Sub
RowsHeightDecrease
Decreases the row height of all the rows in the active table.Public Sub Table_RowsHeightDecrease()
Const sPROCNAME As String = "Table_RowsHeightDecrease"
On Error GoTo AnError
Selection.Tables(1).Cells.RowHeight
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"decrease the row height of all the rows in the active table")
End Sub
RowsHeightIncrease
Increases the row height of all the rows in the active table.Public Sub Table_RowsHeightIncrease()
Const sPROCNAME As String = "Table_RowsHeightIncrease"
On Error GoTo AnError
Selection.Tables(1).Cells.RowHeight
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"increase the row height of all the rows in the active table")
End Sub
RowsIndent
Indents the text in all the rows in a range by a given amount.Public Sub Table_RowsIndent(iRowFirst As Integer, _
Optional iRowLast As Integer = 0, _
Optional sngIndentAmount As Single = sngDEF_COLINDENTLEFT, _
Optional sDirection As String = "LEFT")
Const sPROCNAME As String = "Table_RowsIndent"
Dim irowcounter%
On Error GoTo AnError
If iRowLast = 0 Then iRowLast = iRowFirst
With Selection
For irowcounter = iRowFirst To iRowLast
.Tables(1).cell(irowcounter, 1).Select 'first cell in row
.MoveRight wdCharacter, .Rows.count - 1, wdExtend
If sDirection = "LEFT" Then _
.ParagraphFormat.LeftIndent = sngIndentAmount
If sDirection = "RIGHT" Then _
.ParagraphFormat.RightIndent = sngIndentAmount
Next irowcounter
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
sDirection & " indent all the rows from " & iRowFirst & " and " & iRowLast & _
"by " & sngIndentAmount)
End Sub
RowsNoOf
Returns the total number of rows in the column of the active cell.Public Function Cell_RowsNoOf(Optional ByVal iColNo As Integer = -1, _
Optional ByVal iRowNo As Integer = -1) _
As Integer
On Error GoTo AnError
If (iRowNo > -1) And (iColNo > -1) Then
Selection.Tables(1).Rows(iRowNo).Select
Cell_RowsNoOf = Selection.Rows.count
Else
Selection.Tables(1).Rows(Selection.Cells(1).RowIndex).Select
Cell_RowsNoOf = Selection.Rows.count
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Cell_RowsNoOf", msMODULENAME, 1, _
"return the number of rows in the column of the active cell")
End Function
Sel_RowsDelete
Deletes the rows of any cells currently selected from the active table.Public Sub Sel_RowsDelete()
Const sPROCNAME As String = "Sel_RowsDelete"
On Error GoTo AnError
Selection.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"delete the rows of the cells currently highlighted")
End Sub
Sel_Shade
Public Sub Table_ShadingFormat_Selection(ByVal objSelection As Word.Selection, _
ByVal enBackgroundPatternRGB As Word.WdColor, _
Optional ByVal enForegroundPatternRGB As Word.WdColor = Word.WdColor.wdColorAutomatic, _
Optional ByVal objTexture As Word.WdTextureIndex = Word.WdTextureIndex.wdTextureNone)
Const sPROCNAME As String = "Table_ShadingFormat_Selection"
On Error GoTo ErrorHandler
With objSelection.Cells.Shading
.Texture = objTexture
.ForegroundPatternColor = enForegroundPatternRGB
.BackgroundPatternColor = enBackgroundPatternRGB
End With
Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
Sel_ShadeAlternateCols
Shades all the alternate columns in the highlighted cells.Public Sub Sel_ShadeAlternateCols(Optional sTextureKey As String = "25P", _
Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_ShadeAlternateCols"
Dim icolumnnumber%, irownumber%, itotalcolumns%, itotalrowss%
On Error GoTo AnError
With Selection
irownumber = .Cells(1).RowIndex
icolumnnumber = .Cells(1).ColumnIndex
itotalrowss = irownumber + .Rows.count - 1
itotalcolumns = icolumnnumber + .Columns.count - 1
While icolumnnumber <= itotalcolumns
.Tables(1).cell(irownumber, icolumnnumber).Select
.MoveDown wdLine, itotalrowss - irownumber, wdExtend
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
If icolumnnumber < itotalcolumns Then
.Tables(1).cell(irownumber, icolumnnumber + 1).Select
.MoveDown wdLine, itotalrowss - irownumber, wdExtend
.Cells.Shading.Texture = wdTextureNone 'alternate no shading
End If
icolumnnumber = icolumnnumber + 2 'increment next column to shade
Wend
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"shade the alternate columns of the highlighted cells")
End Sub
Sel_ShadeAlternateRows
Shades all the alternate rows in the highlighted cells.Public Sub Sel_ShadeAlternateRows(Optional sTextureKey As String = "25P", _
Optional sColourKey As String = "DB")
Const sPROCNAME As String = "Sel_ShadeAlternateRows"
Dim icolumnnumber%, irownumber%, itotalcolumns%, itotalrowss%
On Error GoTo AnError
With Selection
irownumber = .Cells(1).RowIndex
icolumnnumber = .Cells(1).ColumnIndex
itotalrowss = irownumber + .Rows.count - 1
itotalcolumns = icolumnnumber + .Columns.count - 1
While irownumber <= itotalrowss
.Tables(1).cell(irownumber, icolumnnumber).Select
.MoveRight wdCharacter, itotalcolumns - icolumnnumber, wdExtend
.Cells.Shading.Texture = Return_ShadingTexture(sTextureKey)
.Cells.Shading.ForegroundPatternColorIndex = Return_ShadingColour(sColourKey)
If irownumber < itotalrowss Then 'if it is not the last row
.Tables(1).cell(irownumber + 1, icolumnnumber).Select
.MoveRight wdCharacter, itotalcolumns - icolumnnumber, wdExtend
.Cells.Shading.Texture = wdTextureNone 'alternate no shading
End If
irownumber = irownumber + 2 'increments by 2 for alternate
Wend
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"shade the alternate rows of the highlighted cells")
End Sub
Sel_SumShow
Determines the total sum of all the numerical values in the highlighted cells.Public Function Sel_SumCells() As Single
Const sPROCNAME As String = "Sel_SumCells"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"return the total sum of all the numerical values" & _
" in the currently highlighted cells")
End Sub
Sel_WidthDecrease
Decreases the width of all the columns of any cells currently selected.Public Sub Sel_WidthDecrease(iDecreaseAmount As Integer)
Const sPROCNAME As String = "Sel_WidthDecrease"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"decrease the width of all the columns" & _
" of all the cells currently selected")
End Sub
Sel_WidthIncrease
Increase the width of all the columns of any cells currently selected are all the cells the same width to start width only in columns that have been reduced !!.Public Sub Sel_WidthIncrease(iIncreaseAmount As Integer)
Const sPROCNAME As String = "Sel_WidthIncrease"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"increase the width of all the columns" & _
" of the cells currently selected")
End Sub
ShadingClear
Removes all shading from the active table.Public Sub Table_ShadingClear()
Const sPROCNAME As String = "Table_ShadingClear"
On Error GoTo AnError
With Selection
.Tables(1).Select
.Cells.Shading.Texture = wdTextureNone 'clears any shading
.Cells.Shading.ForegroundPatternColorIndex = wdNoHighlight
.Font.ColorIndex = wdBlack 'ensures all text is black
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"removes all the shading from the table")
End Sub
SizeReturnIndent
Public Function Table_SizeReturnIndent(ByVal sTableWidth As String) As Single
Const sPROCNAME As String = "Table_SizeReturnIndent"
On Error GoTo ErrorHandler
Select Case sTableWidth
' Case "Indented" : Return sngNORMAL_TABLE_INDENT
' Case "Full Width" : Return sngFULL_WIDTH_TABLE_INDENT
' Case "Report Cover" : Return sngCOVER_TABLE_INDENT
End Select
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
SizeReturnWidth
Public Function Table_SizeReturnWidth(ByRef objDocument As Word.Document, _
ByVal sTableWidth As String) As Single
Const sPROCNAME As String = "Table_SizeReturnWidth"
On Error GoTo ErrorHandler
Select Case sTableWidth
' Case "Indented" : Return modWordTables.Table_WidthGet(objDocument) - sngNORMAL_TABLE_INDENT
' Case "Full Width" : Return modWordTables.Table_WidthGet(objDocument) - sngFULL_WIDTH_TABLE_INDENT
' Case "Report Cover" : Return modWordTables.Table_WidthGet(objDocument) - sngCOVER_TABLE_INDENT
End Select
Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function
SourceAdd
Adds a source to the line directly below the active table.Public Sub Table_SourceAdd(Optional sSource As String = gsBANKNAME)
Const sPROCNAME As String = "Table_SourceAdd"
Dim itotalrowss As Integer
Dim vcell As cell
On Error GoTo AnError
With Selection
.Range.Collapse wdCollapseStart
itotalrowss = .Tables(1).Range.Rows.count
.Tables(1).Range.Rows(itotalrowss).Range.Copy
.Tables(1).Range.Rows(itotalrowss).Range.Paste
For Each vcell In Selection.Tables(1).Range.Rows(itotalrowss + 1).Cells
vcell.Range.Text = "" 'delete all text from the copied row
Next vcell
.Tables(1).Range.InsertAfter "Source: " & sSource
.Tables(1).Range.Rows(itotalrowss + 1).Cells.Merge
.Tables(1).Range.Rows(itotalrowss + 1).ConvertToText _
Separator:=wdSeparateByParagraphs
.Tables(1).cell(itotalrowss + 1, 1).Select
.MoveDown wdLine, 1
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.StartOf Unit:=wdParagraph
.EndOf Unit:=wdParagraph, Extend:=wdExtend 'highlight whole paragraph
.style = sDEF_STYLE_TABLESOURCE
.MoveUp wdLine, 1 'ensures the table is in the middle
End With
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, 1,
"add the source " & sSource & " to the table")
End Sub
SourceChange
Changes the text that currently appears in the source below the active table.Public Sub Table_SourceChange(sSource As String)
Const sPROCNAME As String = "Table_SourceChange"
Dim itotalrowss%, irownumber%, icolumnnumber%
On Error GoTo AnError
With Selection
irownumber = .Cells(1).RowIndex 'get row number of active cell
icolumnnumber = .Cells(1).ColumnIndex 'get column number of active cell
.Range.Collapse wdCollapseStart
itotalrowss = .Tables(1).Range.Rows.count
.Tables(1).cell(itotalrowss, 1).Select
.MoveDown wdLine, 1
.StartOf Unit:=wdParagraph
.EndOf Unit:=wdParagraph, Extend:=wdExtend
.TypeText Text:="Source: " & sSource
.MoveUp wdLine, 1
.Tables(1).cell(irownumber, icolumnnumber).Select
.MoveLeft wdCharacter, 1
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"change the source to " & sSource & " of the table")
End Sub
SourceFormat
probably wont need as the source will be a style ???.Public Sub Table_SourceFormat()
Const sPROCNAME As String = "Table_SourceFormat"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
SourceHasOne
Determines if the active table currently has a source below it.Public Function Table_SourceHasOne() As Boolean
Const sPROCNAME As String = "Table_SourceHasOne"
Dim sparatext$, itotalrowss%
On Error GoTo AnError
With Selection
itotalrowss = .Tables(1).Range.Rows.count
.Tables(1).cell(itotalrowss, 1).Select 'select the last cell in column 1
.MoveDown wdLine, 1
.StartOf Unit:=wdParagraph
.EndOf Unit:=wdParagraph, Extend:=wdExtend 'highlight whole paragraph
sparatext = .Text 'get the text in the above paragraph
If (InStr(1, sparatext, "Source: ") > 0 And _
.style = sDEF_STYLE_TABLESOURCE) Then
Table_SourceHasOne = True
Else
Table_SourceHasOne = False
End If
.MoveUp wdLine, 1 'ensures the table is in the middle
.Tables(1).cell(1, 1).Select 'select the first cell when finished
End With
If gbDEBUG = False Then Exit Function
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"determine if the table has source or not")
End Function
SplitMergedCells
Splits all the merged cells in the active table.Public Sub Table_SplitMergedCells()
Const sPROCNAME As String = "Table_SplitMergedCells"
Dim itotalrowss%, itotalcolumns%, irownumber%
On Error GoTo AnError
With Selection
itotalcolumns = .Tables(1).Range.Columns.count 'table total number of columns
itotalrowss = .Tables(1).Range.Rows.count 'table total number of rows
.Tables(1).cell(itotalrowss, 1).Select 'first cell in the last row
For irownumber = itotalrowss To 1 Step -1 'for every row in the table
Call Table_RowsSplitMerged(irownumber, itotalcolumns, itotalrowss)
.Tables(1).cell(irownumber - 1, 1).Select 'first cell in row above
Next
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"split all the merged cells in the table")
End Sub
Stretcher
Public Sub Table_Stretcher(Optional ByVal oTargetSection As Word.Section = Nothing)
Const sPROCNAME As String = "Table_Stretcher"
'Try
Dim oSection As Word.Section
Dim oTable As Word.Table
If oTargetSection Is Nothing Then
Set oSection = Application.Selection.Sections(1)
Else
Set oSection = oTargetSection
End If
On Error Resume Next
Dim i As Integer
For i = 1 To oSection.Range.Tables.Count
Set oTable = oSection.Range.Tables(i)
If oTable.Rows.LeftIndent >= Application.PointsToInches(0) Then
With oSection.Range.Tables(i)
.PreferredWidth = Application.CentimetersToPoints(Table_SetWidthNew(oTable))
End With
End If
Next i
End Sub
Table_Indent
Indents the active table by a given amnount either on the LEFT or RIGHT.Public Sub Table_Indent(Optional sngLeftIndentAmount As Single = 0, _
Optional sngRightIndentAmount As Single = 0, _
Optional iNoOfHeadingRows As Integer)
Const sPROCNAME As String = "Table_Indent"
Dim itotalcolumns As Integer
On Error GoTo AnError
If Table_InOne = True Then
With Selection
.Tables(1).Select
itotalcolumns = .Tables(1).Range.Columns.count
.Tables(1).cell(4, 1).Select 'select first cell, row 4 ???
'WHAT IF THE TABLE DOESN'T HAVE 4 ROWS ?????????????????
.SelectColumn 'selects the column
.ParagraphFormat.LeftIndent = CentimetersToPoints(sngLeftIndentAmount)
.Tables(1).cell(4, itotalcolumns).Select 'selects the cell in the fourth row ??
.SelectColumn 'selects the column
.ParagraphFormat.RightIndent = CentimetersToPoints(sngRightIndentAmount)
End With
End If
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"indent the table by " & "on the left and and on the right")
End Sub
TitleAdd
Adds a title to the line directly above the active table.Public Sub Table_TitleAdd(Optional bIncludeNos As Boolean = True, _
Optional sTitle As String = "")
Const sPROCNAME As String = "Table_TitleAdd"
On Error GoTo AnError
With Selection
.Tables(1).cell(1, 1).Select
.Range.Collapse wdCollapseStart
.Rows.Add beforerow:=Selection.Range.Rows(1)
.MoveUp wdLine, 1
If .Information(wdWithInTable) = False Then .MoveDown wdLine, 1
.Rows(1).Select
.Range.Cells.Merge
.Range.Rows(1).ConvertToText Separator:=wdSeparateByParagraphs
.ParagraphFormat.Alignment = wdAlignParagraphLeft
.ParagraphFormat.style = sDEF_STYLE_TABLETITLE
If bIncludeNos = True Then
.TypeText Text:="Table "
.Fields.Add .Range, wdFieldEmpty, "SEQ Table", True
.TypeText " "
End If
If sTitle <> "" Then .TypeText sTitle
.MoveDown wdLine, 1 'to ensure you are back within the table
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"add the title " & sTitle & " to the table")
End Sub
TitleFormat
Formats the title directly above the active table.Public Sub Table_TitleFormat(Optional sBackGroundTextureKey As String = "", _
Optional sBackGroundColourKey As String = "", _
Optional sTextColourKey As String = "")
Const sPROCNAME As String = "Table_TitleAdd"
On Error GoTo AnError
With Selection
.Tables(1).cell(1, 1).Select
.MoveUp wdLine, 1 'move to paragraph directly above
.StartOf wdParagraph
.EndOf wdParagraph, wdExtend 'highlight whole paragraph
If sBackGroundColourKey <> "" Then
.ParagraphFormat.Shading.Texture = Return_ShadingTexture(sBackGroundTextureKey)
.ParagraphFormat.Shading.BackgroundPatternColorIndex = _
Return_ShadingColour(sBackGroundColourKey)
Call Para_Select
.Font.ColorIndex = Return_ShadingColour(sTextColourKey)
End If
.MoveDown wdLine, 1 'to ensure you are back within the table
End With
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"format the title of the table")
End Sub
TitleHasOne
Determines if a table has got a totle directly above it.Public Function Table_TitleHasOne() As Boolean
Const sPROCNAME As String = "Table_TitleHasOne"
Dim sparagraphtext$
On Error GoTo AnError
With Selection
.Tables(1).cell(1, 1).Select
.MoveUp wdLine, 1 'move to paragraph directly above
.StartOf wdParagraph
.EndOf wdParagraph, wdExtend 'highlight whole paragraph
sparagraphtext = .Text 'get the text in the above paragraph
Table_TitleHasOne = False
If .style = sDEF_STYLE_TABLETITLE Then Table_TitleHasOne = True
If bDEF_TABLENOALLTABLES = True Then _
If InStr(1, sparagraphtext, "Table ") > 0 Then Table_TitleHasOne = True
.MoveDown wdLine, 1 'ensures the table is in the middle
End With
If gbDEBUG = False Then Exit Function
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"determine if the table has a title")
End Function
ToArray
Transfers the contents of the active table and places them into an array.Public Sub Table_ToArray(vArrayName As Variant, _
Optional irowstart As Integer = 1, _
Optional iColStart As Integer = 1)
Const sPROCNAME As String = "Table_ToArray"
Dim itotalcolumns As Integer
Dim icolumnnumber As Integer
Dim itotalrows As Integer
Dim irownumber As Integer
On Error GoTo AnError:
Application.StatusBar = "Adding the table to an array ..."
itotalcolumns = Selection.Tables(1).Columns.count
itotalrows = Selection.Tables(1).Rows.count
ReDim vArrayName(itotalcolumns - 1, itotalrows - 1, 2)
For icolumnnumber = iColStart To itotalcolumns
For irownumber = irowstart To itotalrows
vArrayName(icolumnnumber - 1, irownumber - 1, 0) = _
Selection.Tables(1).cell(irownumber, icolumnnumber).Range.Text
Next irownumber
Next icolumnnumber
Application.StatusBar = False
If gbDEBUG = False Then Exit Sub
AnError:
' Call Error_Handle(msMODULENAME, sPROCNAME, 1,
Call MsgBox( _
"")
End Sub
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top