MS Word Table Racelanes V4.20
Attribute VB_Name = "Table_Format"
Option Explicit
Option Compare Text
#If VBA7 Then ''need to get character widths to properly set column widths in rcelanes
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
ByVal hdc As LongPtr, ByVal lpString As String, ByVal cbString As Long, lpSize As SIZE) As Long
#Else
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
ByVal hdc As Long, ByVal lpString As String, ByVal cbString As Long, lpSize As SIZE) As Long
#End If
Private Type SIZE
cx As Long
cy As Long
End Type
Public Type RGBColor
r As Long
G As Long
B As Long
End Type
Const cDefalt_Table_Style As String = "Grid Table 3 - Accent 1"
Const cDefaultColor As Long = 13888217 ''RGB(217, 234, 211) ' Galloway green-light fallback
Dim TStyle As New Collection ' table styles
Sub Table_Default_Apply()
Table_Default_Apply_FN
End Sub
Sub Table_Default_Apply_FORCE()
Table_Default_Apply_FN True
End Sub
' Optional force to override table regardless of current style
Sub Table_Default_Apply_FN(Optional Force As Boolean = False)
Dim tb As Table
Dim s As String
Dim doAll As VbMsgBoxResult
Application.UndoRecord.StartCustomRecord "Apply Default Table Style"
If Selection.Information(wdWithInTable) Then
Set tb = Selection.Tables(1)
s = LCase(tb.style)
If Force Or s = "" Or s Like "*normal*" Then
tb.style = cDefalt_Table_Style ' Galloway Green-light
End If
Else
doAll = MsgBox("Cursor is not in a table. Apply default style to ALL tables in the document?", vbYesNo + vbQuestion, "Apply Style to All Tables?")
If doAll = vbYes Then
If Force Then
If MsgBox("This will override styles for all tables in the document. Are you sure?", vbOKCancel + vbExclamation, "Confirm Force Apply") = vbCancel Then GoTo SkipAll
End If
For Each tb In ActiveDocument.Tables
If Force Then tb.style = ActiveDocument.Styles("Table Normal")
s = LCase(tb.style)
If Force Or s = "" Or s Like "*normal*" Then
tb.style = "Grid Table 3 - Accent 1"
End If
Next tb
End If
End If
SkipAll:
Application.UndoRecord.EndCustomRecord
End Sub
Sub Table_Racelanes_Format_bottom_right()
Dim objTable As Table
' Call without dialog
Set objTable = Selection.Tables(1)
If objTable Is Nothing Then
MsgBox "Please run from within a table of equal RowxCol.", vbInformation + vbOKOnly
Exit Sub
End If
Table_Racelanes_Format_bottom_right_FN objTable, False
End Sub
Sub Table_Racelanes_Format_bottom_right_Specify()
Dim objTable As Table
Set objTable = Selection.Tables(1)
If objTable Is Nothing Then
MsgBox "Please run from within a table of equal RowxCol.", vbInformation + vbOKOnly
Exit Sub
End If
' Call with dialog
Table_Racelanes_Format_bottom_right_FN objTable, True
End Sub
Sub Table_Racelanes_Format_bottom_right_FN(ByRef objTable As Table, Optional ColorFontDialog As Boolean = False)
Dim colors() As Long
Dim fonts() As String
Dim UndoRecord As UndoRecord
On Error GoTo err ' Ensure undo record is cleaned up on error
Application.ScreenUpdating = False
Set UndoRecord = Application.UndoRecord
If Not UndoRecord Is Nothing Then
UndoRecord.StartCustomRecord "Table RaceLanes Format Bottom Right"
End If
If ColorFontDialog Then
' Prime the form with existing table colors/fonts
If Table_Prime_frmWdReference Then
frmColorSelection.Show vbModal
End If
' Exit if user cancels dialog
If Not frmColorSelection.Continue Then
frmColorSelection.MeUnload
GoTo CleanupUndo
End If
fonts = frmColorSelection.fonts()
colors = frmColorSelection.colors()
Else
' No dialog � gather defaults from the table
Table_Get_Default_Style_From_Table objTable, fonts, colors
End If
' Apply the colors and fonts
Table_Racelanes_Format_Apply_Colors_FN objTable, colors(), fonts()
GoTo CleanupUndo
err:
MsgBox err.Description, vbCritical + vbOKOnly, "Error in formatting table"
Stop
Resume
CleanupUndo:
If Not UndoRecord Is Nothing Then
UndoRecord.EndCustomRecord
End If
Application.ScreenUpdating = True
End Sub
''function to apply racelanes to passed table with passed colors from other functons
Sub Table_Racelanes_Format_Apply_Colors_FN(ByRef objTable As Table, ByRef colors() As Long, ByRef fonts() As String)
Dim i As Integer
Dim im As Integer
Dim x
Dim r As Range
Dim c As cell
Dim lColor As Long
' Start an undo record
Dim UndoRecord As UndoRecord
Set UndoRecord = Application.UndoRecord
If Not UndoRecord Is Nothing Then
UndoRecord.StartCustomRecord "Apply Table Colors and Fonts"
End If
On Error GoTo CleanupUndo ' Ensure undo record is cleaned up on error
If objTable.Columns.Count <> objTable.Rows.Count Then
MsgBox "Add a row or column if necessary then delete afterwards." & vbCr & vbCr & "Rows: " & objTable.Rows.Count & vbCr & "Cols: " & objTable.Columns.Count, vbCritical + vbOKOnly, "Rows and Columns must be equal to work."
Exit Sub
End If
With objTable
For i = .Columns.Count To 1 Step -1
' Get references
im = (i + 2) Mod 3 + 1 ' Offset to ensure top-left color remains the same
x = Split(fonts(im), ",")
lColor = colors(im)
' Apply properties to the entire column
With objTable.Columns(i)
.Shading.BackgroundPatternColor = lColor
' Apply font properties to each cell in the column
For Each c In .Cells
With c.Range.Font
.name = x(0) ' Font name
.SIZE = x(1) ' Font size
.Color = x(2) ' Font color
End With
Next c
End With
' Apply properties to the entire row
With objTable.Rows(i)
.Shading.BackgroundPatternColor = lColor
' Apply font properties to each cell in the row
For Each c In .Cells
With c.Range.Font
.name = x(0) ' Font name
.SIZE = x(1) ' Font size
.Color = x(2) ' Font color
End With
Next c
End With
' Apply borders
Table_BDR_NONE .Columns(i).Borders(wdBorderHorizontal)
Table_BDR_NONE .Rows(i).Borders(wdBorderVertical)
Table_BDR_Single .Columns(i).Borders(wdBorderLeft)
Table_BDR_Single .Rows(i).Borders(wdBorderTop)
Next i
''Set last row top border as double like an '=' and format left most as dot
i = .Rows.Count
Table_BDR_Double .Rows(i).Borders(wdBorderTop)
Table_BDR_Single .Columns(.Columns.Count).Borders(wdBorderLeft)
Table_BDR_Dot .Rows(i).Borders(wdBorderVertical)
' Reduce padding and center alignment for the last row
With .Rows(i)
For Each c In .Cells
With c
.TopPadding = InchesToPoints(0.01)
.BottomPadding = InchesToPoints(0.1)
.LeftPadding = InchesToPoints(0.01)
.RightPadding = InchesToPoints(0.01)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
End With
Next c
End With
' Align the last cell (bottom-right) to the left
With .cell(.Rows.Count, .Columns.Count)
' Align left
.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
' Apply single left border
Table_BDR_Single .Borders(wdBorderLeft)
End With
' Apply thick borders to the table's outer edges
For i = -4 To -1
Table_BDR_Thick .Borders(i)
Next i
' Format the last row
With .Rows(.Rows.Count)
With .Range
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Font.Bold = True
.Columns.AutoFit
End With
End With
' Format the last cell
.cell(.Rows.Count, .Columns.Count).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
' Check if the table already has a caption
If Not Table_Caption_Applied(objTable) Then
If MsgBox("This table doesn't have a caption. Do you want to add one?", vbYesNo, "Add Caption") = vbYes Then
Table_CaptionInsert objTable
End If
End If
' Prevent rows from breaking across pages and keep paragraphs together
Call Table_PreventPageBreaks_FN(objTable)
''reset col widths
Table_Racelanes_Format_Cols_Reset objTable
End With ''objtable block
GoTo CleanupUndo:
err:
Stop
Debug.Print err.Description
Resume
CleanupUndo:
''End the custom undo record
If Not UndoRecord Is Nothing Then
UndoRecord.EndCustomRecord
End If
End Sub
Sub Table_Racelanes_Format_Cols_Reset(ByRef objTable As Table)
Dim lastRowIdx As Integer, lastColIdx As Integer
Dim colWidths() As Single
Dim iCol As Integer, c As cell
Dim doc As Document
Dim pageWidth As Single, leftMargin As Single, rightMargin As Single
Dim usableWidth As Single, usedWidth As Single, lastColWidth As Single
Dim cellText As String, cellPixels As Long
If objTable Is Nothing Then Exit Sub
lastRowIdx = objTable.Rows.Count
lastColIdx = objTable.Columns.Count
ReDim colWidths(1 To lastColIdx - 1)
' Estimate widths based on pixel width of text in last row (excluding last column)
For Each c In objTable.Rows(lastRowIdx).Cells
If c.ColumnIndex < lastColIdx Then
cellText = Trim(Replace(c.Range.text, Chr(13) & Chr(7), ""))
cellPixels = GetTextPixelWidth(cellText)
colWidths(c.ColumnIndex) = PixelsToPoints(cellPixels) + 1 ' add buffer
End If
Next c
objTable.AllowAutoFit = False
' Apply estimated widths
For iCol = 1 To lastColIdx - 1
objTable.Columns(iCol).SetWidth ColumnWidth:=colWidths(iCol), RulerStyle:=wdAdjustNone
Next iCol
' Calculate last column width to align with page right margin
Set doc = objTable.Range.Document
With doc.PageSetup
pageWidth = .pageWidth
leftMargin = .leftMargin
rightMargin = .rightMargin
End With
usableWidth = pageWidth - leftMargin - rightMargin
usedWidth = 0
For iCol = 1 To lastColIdx - 1
usedWidth = usedWidth + objTable.Columns(iCol).Width
Next iCol
lastColWidth = usableWidth - usedWidth
If lastColWidth > 0 Then
objTable.Columns(lastColIdx).SetWidth ColumnWidth:=lastColWidth, RulerStyle:=wdAdjustNone
End If
End Sub
Function GetTextPixelWidth(text As String) As Long
Dim hdc As LongPtr
Dim sz As SIZE
hdc = GetDC(0) ' Get screen DC
If hdc Then
GetTextExtentPoint32 hdc, text, Len(text), sz
ReleaseDC 0, hdc
GetTextPixelWidth = sz.cx
End If
End Function
Sub Table_PreventPageBreaks()
Dim objTable As Table
Set objTable = Selection.Tables(1)
If objTable Is Nothing Then
MsgBox "Please run from within a table of equal RowxCol.", vbInformation + vbOKOnly
Exit Sub
End If
Table_PreventPageBreaks_FN objTable
End Sub
''Helper prevent table from wrapping unnecessarily
Sub Table_PreventPageBreaks_FN(ByRef objTable As Table) ''ByVal objTable As Table)
Dim row As row, para As Paragraph
For Each row In objTable.Rows
row.AllowBreakAcrossPages = False
Next row
For Each para In objTable.Range.paragraphs
para.Range.ParagraphFormat.KeepTogether = True
para.Range.ParagraphFormat.KeepWithNext = True
Next para
End Sub
' Function to prime the color selection form based on the table's first 3x3 diagonal cells
''Include frmColorselection
Function Table_Prime_frmWdReference() As Boolean
Dim objTable As Table
''Dim cell1 As Range, cell2 As Range, cell3 As Range
Dim diagonalColors(1 To 3) As Long
Dim diagonalFonts(1 To 3) As String
Dim color1 As Long, color2 As Long, color3 As Long
Dim font1 As String, font2 As String, font3 As String
Dim i As Integer
On Error Resume Next
Set objTable = Selection.Tables(1)
On Error GoTo 0
If objTable Is Nothing Then
MsgBox "Please select a table first.", vbExclamation, "Error"
Table_Prime_frmWdReference = False
Exit Function
End If
' Ensure the table has at least 3 rows and 3 columns
If objTable.Rows.Count < 3 Or objTable.Columns.Count < 3 Then
MsgBox "Table must have at least 3 rows and 3 columns to prime the form.", vbExclamation, "Error"
Table_Prime_frmWdReference = False
Exit Function
End If
''Preset colors and styles based on table---------------------------------
' Get diagonal cell properties color/fonts
For i = 1 To 3
diagonalColors(i) = objTable.cell(i, i).Shading.BackgroundPatternColor
diagonalFonts(i) = GetFontString(objTable.cell(i, i).Range.Font)
Next i
' Pass the extracted colors and fonts to the form
frmColorSelection.SetColorsAndFonts diagonalColors(), diagonalFonts()
Table_Prime_frmWdReference = True
End Function
' Function to check if a table already has a caption
Function Table_Caption_Applied(objTable As Table) As Boolean
Dim rngBefore As Range
Dim fld As Field
Dim hasCaption As Boolean
Set rngBefore = objTable.Range
rngBefore.Collapse Direction:=wdCollapseStart
rngBefore.MoveStart wdParagraph, -1 ' Move to the paragraph before the table
' Loop through fields in that range
For Each fld In rngBefore.Fields
If fld.Type = wdFieldSequence Then
If InStr(1, fld.Code.text, "Table", vbTextCompare) > 0 Then
hasCaption = True
Exit For
End If
End If
Next fld
Table_Caption_Applied = hasCaption
End Function
Public Sub Table_CaptionInsert(Optional objTable As Table)
On Error Resume Next
If objTable Is Nothing Then Set objTable = Selection.Tables(1)
If objTable Is Nothing Then
MsgBox "Please select a table first.", vbExclamation, "Error"
Exit Sub
End If
objTable.Range.InsertCaption _
Label:=wdCaptionTable, _
Position:=wdCaptionPositionAbove
End Sub
Sub Table_BDR_NONE(Bdr As Border) ' clear borders
With Bdr
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.LineStyle = wdLineStyleNone
End With
End Sub
Sub Table_BDR_Single(Bdr As Border)
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
With Bdr
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
End With
End Sub
Sub Table_BDR_Thin(Bdr As Border)
With Bdr
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth025pt
End With
End Sub
Sub Table_BDR_Dash(Bdr As Border)
With Bdr
.LineStyle = wdLineStyleDashLargeGap
.LineWidth = wdLineWidth025pt
End With
End Sub
Sub Table_BDR_Dot(Bdr As Border)
With Options
.DefaultBorderLineStyle = wdLineStyleDot
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
With Bdr
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
End Sub
Sub Table_BDR_Thick(Bdr As Border)
With Bdr
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
End Sub
Sub Table_BDR_Double(Bdr As Border)
With Options
.DefaultBorderLineStyle = wdLineStyleDouble
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
With Bdr
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
End Sub
' Function to apply both color and font to a specific cell
''Include frmColorselection
Sub Table_Cell_Set_Format(cell As cell, backgroundColor As Long, Font As String)
Dim fontParts As Variant
fontParts = Split(Font, ",")
' Apply background color
cell.Shading.BackgroundPatternColor = backgroundColor
' Apply font properties
With cell.Range.Font
.name = fontParts(0)
.SIZE = fontParts(1)
.Color = fontParts(2)
End With
End Sub
' Helper function to get font properties as a string
''Include frmColorselection
Function GetFontString(f As Font) As String
GetFontString = f.name & "," & f.SIZE & "," & f.Color
End Function
''------------------
Sub Table_Bind_Outer_Tables_AllowColumnBreaks()
' Variables for document, table, and undo functionality
Dim doc As Document ' Active document reference
Dim tbl As Table ' Table in the document being processed
Dim outerTables As Collection ' Collection to store outer (non-nested) tables
Dim UndoRecord As UndoRecord ' Undo record for grouping changes
Dim undoStarted As Boolean ' Flag to track undo group status
' Variables for user selection and interaction
Dim selRange As Range ' Range of the user's selected text
Dim isTextSelected As Boolean ' Boolean flag for whether text is selected
Dim response As VbMsgBoxResult ' User's response to OK/Cancel prompt
Dim para As Paragraph ' Paragraph within the table range
On Error GoTo errHandler
' Initialize undo record
Set UndoRecord = Application.UndoRecord
undoStarted = False
' Set active document
Set doc = ActiveDocument
' Determine if text is selected
isTextSelected = (Selection.Type = wdSelectionNormal) And (Selection.text <> "")
' Handle no selected text
If Not isTextSelected Then
response = MsgBox("No selected text. Process all tables in the document to allow column breaks but prevent page breaks?", vbOKCancel + vbQuestion)
If response = vbCancel Then GoTo clearResources
Set selRange = doc.Content ' If no selection, process the entire document
Else
Set selRange = Selection.Range ' Use the selected text
End If
' Start the undo group
UndoRecord.StartCustomRecord "Bind Outer Tables Allow Column Breaks"
undoStarted = True
' Initialize outer tables collection
Set outerTables = New Collection
' Identify outer tables in the selection
For Each tbl In selRange.Tables
' Check if the table is nested
If tbl.NestingLevel = 1 Then
outerTables.Add tbl ' Add only non-nested tables to the collection
End If
Next tbl
' Process each outer table
For Each tbl In outerTables
' Work with the entire table's range to avoid issues with vertically merged cells
For Each para In tbl.Range.paragraphs
With para.Range.ParagraphFormat
.KeepTogether = True ' Prevent paragraph lines from splitting across pages
.KeepWithNext = False ' Allow the next paragraph to start in a new column
End With
Next para
Next tbl
' Notify the user of success
MsgBox "Tables processed to allow column breaks but prevent page breaks.", vbInformation
GoTo clearResources
errHandler:
' Error handling: print the error, pause execution, and resume
Debug.Print "Error: " & err.Description
Debug.Assert False ' Pause execution for debugging
Resume clearResources ' Resume cleanup and finalize undo
clearResources:
' End the undo group if it was started
If undoStarted Then
UndoRecord.EndCustomRecord
End If
End Sub
''table FONT&Color helpers
Sub Table_Get_Default_Style_From_Table(ByRef objTable As Table, ByRef fonts() As String, ByRef colors() As Long)
Dim i As Integer
Dim f As Font
Dim colorValue As Long
ReDim fonts(1 To 3)
ReDim colors(1 To 3)
On Error GoTo err:
' Apply default style if table has no defined or normal style
If (objTable.style Is Nothing) _
Or (Trim(objTable.style) = "") _
Or (LCase(objTable.style) Like "*normal*") Then
objTable.style = cDefalt_Table_Style
End If
' Loop through diagonal cells (1,1), (2,2), (3,3)
For i = 1 To 3
On Error Resume Next
' Font
Set f = objTable.cell(i, i).Range.Font ''will default to last on error
fonts(i) = f.name & "," & f.SIZE & "," & f.Color
' Color
colorValue = objTable.cell(i, i).Shading.BackgroundPatternColor
On Error GoTo 0
If colorValue = wdColorAutomatic Or colorValue = -1 Or colorValue = 0 Then
colorValue = cDefaultColor
End If
colors(i) = colorValue
Next i
GoTo clear
err:
Debug.Print err.Description
Stop
Resume
clear:
End Sub
''----------------------------------------
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmColorSelection
Caption = "Table Raceway Color Picker"
ClientHeight = 3780
ClientLeft = 120
ClientTop = 465
ClientWidth = 3930
OleObjectBlob = "frmColorSelection.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "frmColorSelection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''Include reference to C:\Windows\System32\FM20.DLL for text form types.
Option Explicit
Option Compare Text
Public Cancelled As Boolean
' Getter for the UserAction
Public Function Continue() As Boolean
Continue = Not (Cancelled) ''pass back if cancelled or not.
End Function
Private Sub txtFont1_Enter()
Call SelectFont(txtFont1)
End Sub
Private Sub txtFont2_Enter()
Call SelectFont(txtFont2)
End Sub
Private Sub txtFont3_Enter()
Call SelectFont(txtFont3)
End Sub
' Public function to return the array
Public Property Get colors() As Variant
Dim CVals(1 To 3) As Long ''continer for CVals
CVals(1) = CLng(txtColor1.Value)
CVals(2) = CLng(txtColor2.Value)
CVals(3) = CLng(txtColor3.Value)
colors = CVals()
End Property
' Public function to return the array
Public Property Get fonts() As Variant
Dim FVals(1 To 3) As String ''container for FVals
FVals(1) = txtFont1.Value
FVals(2) = txtFont2.Value
FVals(3) = txtFont3.Value
fonts = FVals()
End Property
' Method to set colors and fonts from the table using arrays
Public Sub SetColorsAndFonts(ByRef colors() As Long, ByRef fonts() As String)
' Validate that the arrays have at least 3 elements
If UBound(colors) < 3 Or UBound(fonts) < 3 Then
MsgBox "The provided arrays must have at least 3 elements.", vbExclamation, "Error"
Exit Sub
End If
' Set the colors in the form
txtColor1.Value = colors(1)
txtColor2.Value = colors(2)
txtColor3.Value = colors(3)
' Set the fonts in the form
txtFont1.Value = fonts(1)
txtFont2.Value = fonts(2)
txtFont3.Value = fonts(3)
End Sub
Private Sub UserForm_Initialize()
' If SetColorsAndFonts method is not called, fall back to current cell's properties
If txtColor1.Value = "" Then ''assume all values unset...
' Initialize default values for colors and fonts based on the current cell's properties
Dim currentFont As Font
Dim currentShading As Shading
' Set currentFont and currentShading based on the selection
Set currentFont = Selection.Font
Set currentShading = Selection.Shading
' Initialize color values based on the current cell's shading
txtColor1.Value = currentShading.BackgroundPatternColor
txtColor2.Value = currentShading.BackgroundPatternColor
txtColor3.Value = currentShading.BackgroundPatternColor
' Initialize font values based on the current cell's font
txtFont1.Value = currentFont.name & "," & currentFont.SIZE & "," & currentFont.Color
txtFont2.Value = currentFont.name & "," & currentFont.SIZE & "," & currentFont.Color
txtFont3.Value = currentFont.name & "," & currentFont.SIZE & "," & currentFont.Color
End If
Cancelled = True
'ConvertWordColorToRGBAndSet txtColor1, txtFont1
'ConvertWordColorToRGBAndSet txtColor2, txtFont2
'ConvertWordColorToRGBAndSet txtColor3, txtFont3
End Sub
Private Sub txtColor1_Enter() 'txtColor1_Enter() 'btnColor1_Click()
Call SelectColor(txtColor1)
End Sub
Private Sub txtColor2_Enter() 'btnColor2_Click()
Call SelectColor(txtColor2)
End Sub
Private Sub txtColor3_Enter()
Call SelectColor(txtColor3)
End Sub
Private Sub btnFont1_Click()
Call SelectFont(txtFont1)
End Sub
Private Sub btnFont2_Click()
Call SelectFont(txtFont2)
End Sub
Private Sub btnFont3_Click()
Call SelectFont(txtFont3)
End Sub
Private Sub btnOK_Click()
Cancelled = False
Me.hide
End Sub
Private Sub btnCancel_Click()
Cancelled = True
Me.hide
End Sub
Private Sub SelectColor(txtColor As MSForms.TextBox)
' Use the standard Word color picker dialog
On Error Resume Next
Application.Dialogs(wdDialogFormatBordersAndShading).Show
On Error GoTo 0
txtColor.Value = Selection.Shading.BackgroundPatternColor
End Sub
Private Sub SelectFont(txtFont As MSForms.TextBox)
' Use the standard Word font dialog
On Error Resume Next
Application.Dialogs(wdDialogFormatFont).Show
On Error GoTo 0
txtFont.Value = Selection.Font.name & "," & Selection.Font.SIZE & "," & Selection.Font.Color
End Sub
'Private Sub FormatTableWithSelectedColors(ByRef colors() As Long, ByRef fonts() As String)
' Call Table_Apply_Colors(colors(), fonts())
'End Sub
''''''''''''Colorize cells to reflect word colors
Private Sub ConvertWordColorToRGBAndSet(txtColor As MSForms.TextBox, txtFont As MSForms.TextBox)
Dim FontColorComponents As RGBColor
Dim BackColorComponents As RGBColor
Dim FontWdColor As Long
Dim BackWdColor As Long
' Extract Font color from txtFont.Value (ensure it's correctly parsed)
FontWdColor = CLng(Split(txtFont.Value, ",")(UBound(Split(txtFont.Value, ","))))
' Convert Word Font Color to RGB
Call WDCRGB(FontWdColor, FontColorComponents)
' Set ForeColor for txtColor and txtFont
txtColor.ForeColor = RGB(FontColorComponents.r, FontColorComponents.G, FontColorComponents.B)
txtFont.ForeColor = RGB(FontColorComponents.r, FontColorComponents.G, FontColorComponents.B)
' Extract Background color from txtColor.Value
BackWdColor = CLng(txtColor.Value)
' Convert Word Background Color to RGB
Call WDCRGB(BackWdColor, BackColorComponents)
' Set BackColor for txtColor and txtFont
txtColor.BackColor = RGB(BackColorComponents.r, BackColorComponents.G, BackColorComponents.B)
txtFont.BackColor = RGB(BackColorComponents.r, BackColorComponents.G, BackColorComponents.B)
End Sub
Private Sub WDCRGB(WdColor As Long, ByRef RGBComp As RGBColor)
' Extract RGB components from the Word WdColor value
RGBComp.r = WdColor Mod 256
RGBComp.G = (WdColor \ 256) Mod 256
RGBComp.B = (WdColor \ 65536) Mod 256
End Sub
Function MeUnload()
Unload Me
End Function
''---------------------------------------
Comments
Post a Comment