Help with Borderrs and Shading Dialog

[Greg Maxey]

I am trying to return the value of user settings in the Borders and Shading
dialog. I can determine the Left, Right, Top, Bottom, Horizontal, and
Vertical border styles selected an then use that information later on to set
one or more table borders. What I can't figure out is how to determine the
line color and line width that a user selects.

Here is simplified version of my overall code that shows how I can get the
border style choosen in the dialog. I just can't figure out how to return
the user selected line width or color.

Thanks.


Sub Test()
Dim LS As Long
Dim RS As Long
Dim TS As Long
Dim BS As Long
Dim VS As Long
Dim HS As Long
Dim Color '????????????
Dim LineWidth '?????????????
With Dialogs(wdDialogFormatBordersAndShading)
If .Display <> 0 Then
LS = .Leftstyle
RS = .RightStyle
TS = .TopStyle
BS = .BottomStyle
HS = .HorizStyle
VS = .VertStyle
Color = ??????????????
LindeWidth = ?????????????
End If
End With
With Selection.Tables(1)
With .Borders(wdBorderLeft)
.LineStyle = LS
.LineWidth = wdLineWidth050pt 'Replace this with LineWidth selected by
user
.Color = wdColorRed 'Replace this with Color selected by user
End With
End With
End Sub

 

[Graham Mayor]

How about

Dim BLStyle As String
Dim BLWidth As String
Dim BLColor As String
Dim BRStyle As String
Dim BRWidth As String
Dim BRColor As String
Dim BTStyle As String
Dim BTWidth As String
Dim BTColor As String
Dim BBStyle As String
Dim BBWidth As String
Dim BBColor As String
Dim BHStyle As String
Dim BHWidth As String
Dim BHColor As String
Dim BVStyle As String
Dim BVWidth As String
Dim BVColor As String
Dim BDStyle As String
Dim BUStyle As String
Dim BShadow As Boolean

With Selection.Tables(1)
With .Borders(wdBorderLeft)
BLStyle = .LineStyle
BLWidth = .LineWidth
BLColor = .Color
End With
With .Borders(wdBorderRight)
BRStyle = .LineStyle
BRWidth = .LineWidth
BRColor = .Color
End With
With .Borders(wdBorderTop)
BTStyle = .LineStyle
BTWidth = .LineWidth
BTColor = .Color
End With
With .Borders(wdBorderBottom)
BBStyle = .LineStyle
BBWidth = .LineWidth
BBColor = .Color
End With
With .Borders(wdBorderHorizontal)
BHStyle = .LineStyle
BHWidth = .LineWidth
BHColor = .Color
End With
With .Borders(wdBorderVertical)
BVStyle = .LineStyle
BVWidth = .LineWidth
BVColor = .Color
End With
BDStyle = .Borders(wdBorderDiagonalDown).LineStyle
BUStyle = .Borders(wdBorderDiagonalUp).LineStyle
BShadow = .Borders.Shadow
End With
MsgBox BLStyle & vbCr & _
BLWidth & vbCr & _
BLColor & vbCr & _
BRStyle & vbCr & _
BRWidth & vbCr & _
BRColor & vbCr & _
BTStyle & vbCr & _
BTWidth & vbCr & _
BTColor & vbCr & _
BBStyle & vbCr & _
BBWidth & vbCr & _
BBColor & vbCr & _
BHStyle & vbCr & _
BHWidth & vbCr & _
BHColor & vbCr & _
BVStyle & vbCr & _
BVWidth & vbCr & _
BVColor & vbCr & _
BDStyle & vbCr & _
BUStyle & vbCr & _
BShadow

?

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[Greg Maxey]

I have found most of the solution myself through trial and error and using
VBA help file. The ultimate goal is to create a macro that will apply
common borders and shading to all tables in a documnet. Lene Fredborg is
part of the code looks familiar it is because I got the idea after looking
at your web article on apply common borders.

I learned that the values returned by the dialog for border line weights and
shading texture do not convert directly to linewidths and texture in the
table oject. I had to use a function to convert these to values the table
object would use. Another thing that I was not able to work out is it seems
that ther is no way to convert the .shading value returned for some of the
textures: e.g., 12.5%, 15%, 35%, 37.5% ect. All of these return a value
of -1.

If anyone can see a way to get a useful return for the texture values
mentioned above please let me know.

Thanks.

Public Sub ApplyUniformBordersAndShadingToAllTables()
Dim oTables As Tables
Dim oTable As Table
Dim Title As String
Dim n As Long
Dim i As Long
Dim Shading
Dim TopStyle As Long
Dim LeftStyle As Long
Dim BottomStyle As Long
Dim RightStyle As Long
Dim HorizStyle As Long
Dim VertStyle As Long
Dim TopWeight As Long
Dim LeftWeight As Long
Dim BottomWeight As Long
Dim RightWeight As Long
Dim HorizWeight As Long
Dim VertWeight As Long
Dim BorderObjectType
Dim BorderArtWeight
Dim BorderArt
Dim ForegroundRGB
Dim BackgroundRGB
Dim TopColorRGB
Dim LeftColorRGB
Dim BottomColorRGB
Dim RightColorRGB
Dim HorizColorRGB
Dim VertColorRGB
Set oTables = ActiveDocument.Tables
Title = "Apply Uniform Borders to All Tables"
If Not Selection.Information(wdWithInTable) Then oTables(1).Select
If oTables.Count > 0 Then
If MsgBox("This command applies uniform table borders " & _
"to all tables in the active document." & vbCr & vbCr & _
"Do you want to continue?", vbQuestion + vbYesNo, Title) = vbYes
Then
Err_ReEntry:
With Dialogs(wdDialogFormatBordersAndShading)
If .Display <> 0 Then
Shading = ConvertShading(.Shading)
On Error GoTo Error_Handler
If Shading = "No VBA conversion" Then
Err.Raise vbObjectError + 1
End If
ForegroundRGB = .ForegroundRGB
BackgroundRGB = .BackgroundRGB
LeftStyle = .LeftStyle
RightStyle = .RightStyle
TopStyle = .TopStyle
BottomStyle = .BottomStyle
HorizStyle = .HorizStyle
VertStyle = .VertStyle
TopColorRGB = .TopColorRGB
LeftColorRGB = .LeftColorRGB
BottomColorRGB = .BottomColorRGB
RightColorRGB = .RightColorRGB
HorizColorRGB = .HorizColorRGB
VertColorRGB = .VertColorRGB
TopWeight = ConvertWeight(.TopWeight)
LeftWeight = ConvertWeight(.LeftWeight)
BottomWeight = ConvertWeight(.BottomWeight)
RightWeight = ConvertWeight(.RightWeight)
HorizWeight = ConvertWeight(.HorizWeight)
VertWeight = ConvertWeight(.VertWeight)
End If
End With
For Each oTable In oTables
'Count tables - used in message
n = n + 1
With oTable
With .Shading
.ForegroundPatternColor = ForegroundRGB
.BackgroundPatternColor = BackgroundRGB
.Texture = Shading
End With
On Error Resume Next
With .Borders(wdBorderLeft)
.LineStyle = LeftStyle
.LineWidth = LeftWeight
.Color = LeftColorRGB
End With
With .Borders(wdBorderRight)
.LineStyle = RightStyle
.LineWidth = RightWeight
.Color = RightColorRGB
End With
With .Borders(wdBorderTop)
.LineStyle = TopStyle
.LineWidth = TopWeight
.Color = TopColorRGB
End With
With .Borders(wdBorderBottom)
.LineStyle = BottomStyle
.LineWidth = BottomWeight
.Color = BottomColorRGB
End With
With .Borders(wdBorderHorizontal)
.LineStyle = HorizStyle
.LineWidth = HorizWeight
.Color = HorizColorRGB
End With
With .Borders(wdBorderVertical)
.LineStyle = VertStyle
.LineWidth = VertWeight
.Color = VertColorRGB
End With
On Error GoTo 0
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
Next oTable
MsgBox "Finished applying borders to " & n & " tables.", vbOKOnly, Title
Else
'Stop if user did not click Yes
Exit Sub
End If
Else
'Stop - no tables are found
MsgBox "The document contains no tables.", vbInformation, Title
End If
Exit Sub
Error_Handler:
If Err.Number = vbObjectError + 1 Then
MsgBox "This texture setting is unavailable for this process.", vbOKOnly,
"Texture Unavailable"
Resume Err_ReEntry
End If
End Sub
Function ConvertWeight(ByRef weight As Long) As Long
Select Case weight
Case 0
ConvertWeight = weight + 2
Case 1
ConvertWeight = weight + 3
Case 2
ConvertWeight = weight + 4
Case 3
ConvertWeight = weight + 5
Case 4
ConvertWeight = weight + 8
Case 5
ConvertWeight = weight + 13
Case 6
ConvertWeight = weight + 18
Case 7
ConvertWeight = weight + 29
Case 8
ConvertWeight = weight + 40
Case Else
End Select
End Function
Function ConvertShading(ByRef Shading As Long)
Select Case Shading
Case -1
ConvertShading = "No VBA conversion"
Case 0
ConvertShading = 0
Case 1
ConvertShading = 1000
Case 2
ConvertShading = 50
Case 3
ConvertShading = 100
Case 4
ConvertShading = 200
Case 5
ConvertShading = 250
Case 6
ConvertShading = 300
Case 7
ConvertShading = 400
Case 8
ConvertShading = 500
Case 9
ConvertShading = 600
Case 10
ConvertShading = 700
Case 11
ConvertShading = 750
Case 12
ConvertShading = 800
Case 13
ConvertShading = 900
Case 14
ConvertShading = -1
Case 15
ConvertShading = -2
Case 16
ConvertShading = -3
Case 17
ConvertShading = -4
Case 18
ConvertShading = -5
Case 19
ConvertShading = -6
Case 20
ConvertShading = -7
Case 21
ConvertShading = -8
Case 22
ConvertShading = -9
Case 23
ConvertShading = -10
Case 24
ConvertShading = -11
Case 25
ConvertShading = -12
End Select
End Function

 

[Greg Maxey]

Graham,

We all know that I have a problem with simple English and my initial
question was probably poorly written. I was trying to get the values from
the BordersAndShading dialog that corresponded to the values used to format
borders and shading with VBA. I think you will see what I was trying to do
by looking at the code in my second post.

Thanks anyway.

 

[Tony Jollans]

Hi Greg,

..LineColorRGB gives the colour.I don't think the width is available.

However, the values in the dropdowns only really have meaning within the
dialog - once chosen they must be applied to individual borders, and each
may have a different value - which you already seem to be picking up.

 

[Greg Maxey]

Tony,

I found a way to get width. It is the TopWeight, LeftWeight, etc. argument
of the dialog, but it has to be converted to a meaningful value to apply as
a line width.

Thanks.

 

[Jay Freedman]

Hi Greg,

I see you found a way to convert the line weights from the dialog to the values
you need. If you're interested in something a little simpler and more
understandable, here's an explanation.

The values you get from the dialog are, of course, just the index of the
selection in the dropdown. The values you need to set the Borders properties are
members of the WdLineWidth collection. If you look up that collection in the
Object Browser, they're a strange sequence (2, 4, 6, 8, 12, 18, 24, 36, 48). But
they have mnemonic names so you don't have to know the actual values.

So if you initialize an array with the names corresponding to what you see in
the dialog dropdown, then you can get the proper value by using the dialog
return value as an index into that array:

Dim LineWeights()
LineWeights = Array( _
wdLineWidth025pt, wdLineWidth050pt, _
wdLineWidth075pt, wdLineWidth100pt, _
wdLineWidth150pt, wdLineWidth225pt, _
wdLineWidth300pt, wdLineWidth450pt, _
wdLineWidth600pt)

TopWeight = LineWeights(.TopWeight)
' etc.

There's probably something similar for converting the shading, but I haven't
looked at it yet.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so all
may benefit.

 

[Greg Maxey]

Jay,

Yes you are right. You can get most of the shading selections into an array,
but several of them return -1 rather than the expected sequence in the list.
Because of that I still need to use a function.

I think my next step is to see if I can actually format the tables using
another instance of the dialog rather than using the table object. Seems I
should be able to set the values of the dialog based on the intial user
selection and then .execute.



Public Sub ApplyUniformBordersAndShadingToAllTables()
Dim oTables As Tables
Dim oTable As Table
Dim Title As String
Dim n As Long
Dim i As Long
Dim Shading
Dim Shadow
Dim TopStyle As Long
Dim LeftStyle As Long
Dim BottomStyle As Long
Dim RightStyle As Long
Dim HorizStyle As Long
Dim VertStyle As Long
Dim TL2BRStyle As Long, TR2BLStyle As Long
Dim TopWeight As Long
Dim LeftWeight As Long
Dim BottomWeight As Long
Dim RightWeight As Long
Dim HorizWeight As Long
Dim VertWeight As Long
Dim TL2BRWeight As Long, TR2BLWeight As Long
Dim ForegroundRGB
Dim BackgroundRGB
Dim TopColorRGB
Dim LeftColorRGB
Dim BottomColorRGB
Dim RightColorRGB
Dim HorizColorRGB
Dim VertColorRGB
Dim TL2BRColorRGB, TR2BLColorRGB
Dim LineWeights()
'Dim Shading()
On Error Resume Next
Set oTables = ActiveDocument.Tables
On Error GoTo 0
Title = "Apply Uniform Borders to All Tables"
If Not Selection.Information(wdWithInTable) Then oTables(1).Select
If oTables.Count > 0 Then
If MsgBox("This command applies uniform table borders " & _
"to all tables in the active document." & vbCr & vbCr & _
"Do you want to continue?", vbQuestion + vbYesNo, Title) = vbYes
Then
LineWeights = Array(wdLineWidth025pt, wdLineWidth050pt, _
wdLineWidth075pt, wdLineWidth100pt, _
wdLineWidth150pt, wdLineWidth225pt, _
wdLineWidth300pt, wdLineWidth450pt, _
wdLineWidth600pt)
Err_ReEntry:
With Dialogs(wdDialogFormatBordersAndShading)
If .Display <> 0 Then
Shadow = .Shadow
Shading = ConvertShading(.Shading)
On Error GoTo Error_Handler
If Shading = "No VBA conversion" Then
Err.Raise vbObjectError + 1
End If
ForegroundRGB = .ForegroundRGB
BackgroundRGB = .BackgroundRGB
LeftStyle = .LeftStyle
RightStyle = .RightStyle
TopStyle = .TopStyle
BottomStyle = .BottomStyle
HorizStyle = .HorizStyle
VertStyle = .VertStyle
TL2BRStyle = .TL2BRStyle
TR2BLStyle = .TR2BLStyle
TopColorRGB = .TopColorRGB
LeftColorRGB = .LeftColorRGB
BottomColorRGB = .BottomColorRGB
RightColorRGB = .RightColorRGB
HorizColorRGB = .HorizColorRGB
VertColorRGB = .VertColorRGB
TL2BRColorRGB = .TL2BRColorRGB
TR2BLColorRGB = .TR2BLColorRGB
TopWeight = LineWeights(.TopWeight)
LeftWeight = LineWeights(.LeftWeight)
BottomWeight = LineWeights(.BottomWeight)
RightWeight = LineWeights(.RightWeight)
HorizWeight = LineWeights(.HorizWeight)
VertWeight = LineWeights(.VertWeight)
On Error Resume Next
TL2BRWeight = LineWeights(.TL2BRWeight)
TR2BLWeight = LineWeights(.TR2BLWeight)
On Error GoTo 0
End If
End With
For Each oTable In oTables
Application.ScreenRefresh
'Count tables - used in message
n = n + 1
With oTable
With .Shading
.ForegroundPatternColor = ForegroundRGB
.BackgroundPatternColor = BackgroundRGB
.Texture = Shading
End With
On Error Resume Next
With .Borders(wdBorderLeft)
.LineStyle = LeftStyle
.LineWidth = LeftWeight
.Color = LeftColorRGB
End With
With .Borders(wdBorderRight)
.LineStyle = RightStyle
.LineWidth = RightWeight
.Color = RightColorRGB
End With
With .Borders(wdBorderTop)
.LineStyle = TopStyle
.LineWidth = TopWeight
.Color = TopColorRGB
End With
With .Borders(wdBorderBottom)
.LineStyle = BottomStyle
.LineWidth = BottomWeight
.Color = BottomColorRGB
End With
With .Borders(wdBorderHorizontal)
.LineStyle = HorizStyle
.LineWidth = HorizWeight
.Color = HorizColorRGB
End With
With .Borders(wdBorderVertical)
.LineStyle = VertStyle
.LineWidth = VertWeight
.Color = VertColorRGB
End With
With .Borders(wdBorderDiagonalUp)
.LineStyle = TR2BLStyle
.LineWidth = TR2BLWeight
.Color = TR2BLColorRGB
End With
With .Borders(wdBorderDiagonalDown)
.LineStyle = TL2BRStyle
.LineWidth = TL2BRWeight
.Color = TL2BRColorRGB
End With
On Error GoTo 0
.Borders.Shadow = Shadow
End With
Next oTable
Application.ScreenRefresh
MsgBox "Finished applying borders to " & n & " tables.", vbOKOnly, Title
Else
'Stop if user did not click Yes
Exit Sub
End If
Else
'Stop - no tables are found
MsgBox "The document contains no tables.", vbInformation, Title
End If
Exit Sub
Error_Handler:
If Err.Number = vbObjectError + 1 Then
MsgBox "This texture setting is unavailable for this process.", vbOKOnly,
"Texture Unavailable"
Resume Err_ReEntry
End If
End Sub
Function ConvertShading(ByRef ShadingSel As Long)
Dim lngVar
Dim Shading
Shading = Array(wdTextureNone, wdTextureSolid, wdTexture5Percent, _
wdTexture10Percent, wdTexture20Percent, wdTexture25Percent,
_
wdTexture30Percent, wdTexture40Percent, wdTexture50Percent,
_
wdTexture60Percent, wdTexture70Percent, wdTexture75Percent,
_
wdTexture80Percent, wdTexture90Percent,
wdTextureDarkHorizontal, _
wdTextureDarkVertical, wdTextureDarkDiagonalDown, _
wdTextureDarkDiagonalUp, wdTextureDarkCross, _
wdTextureDarkDiagonalCross, wdTextureHorizontal,
wdTextureVertical, _
wdTextureDiagonalDown, wdTextureDiagonalUp, wdTextureCross,
_
wdTextureDiagonalCross)
Select Case ShadingSel
Case -1
lngVar = InputBox("VBA can not directly convert your texture selection."
& vbCr + vbCr _
& "Please enter the texture percentage value you selected in
the" & _
" space provided.", "Input Texture Percentage")
Select Case lngVar
Case 12.5, 15, 35, 45, 55, 62.5, 65, 85, 87.5, 95
ConvertShading = 10 * lngVar
Case Else
ConvertShading = "No VBA conversion"
End Select
Case Else
ConvertShading = Shading(ShadingSel)
End Select
End Function

 

[Greg Maxey]

Jay,

There is definately some disconnect between the BuiltInDialog texture list
selection and what gets applied as shading in the table. Most of the
choices in the list return a positive sequential number, but several 12.5%,
15%, 35%, 45% etc. all return -1. Accrodingly I am using a combination of
an Array with most of the values and a Select Case statement to provide the
rstin in a Function. As a result of this, I was not able to make full use
of the built in dialog to actually reformat each table. If any of those
choice that return -1 are selected then the shading becomes solid 100%.
Below is the complete code that seems to be working correctly in Word2003.
I have left in the statements (commented out) where I tried to use the
Dialog a second time to actually format the tables. I you have time and
interest then maybe you can see something that I was doing wrong.

Thanks.

Public Sub ApplyUniformBordersAndShadingToAllTables()
Dim oTables As Tables
Dim oTable As Table
Dim Title As String
Dim n As Long, i As Long
Dim Shading, Shadow
Dim TopStyle As Long, LeftStyle As Long, BottomStyle As Long
Dim RightStyle As Long, HorizStyle As Long, VertStyle As Long
Dim TL2BRStyle As Long, TR2BLStyle As Long
Dim TopWeight As Long, LeftWeight As Long, BottomWeight As Long
Dim RightWeight As Long, HorizWeight As Long, VertWeight As Long
Dim TL2BRWeight As Long, TR2BLWeight As Long
Dim ForegroundRGB, BackgroundRGB
Dim TopColorRGB, LeftColorRGB, BottomColorRGB
Dim RightColorRGB, HorizColorRGB, VertColorRGB
Dim TL2BRColorRGB, TR2BLColorRGB
Dim LineWeights()
On Error Resume Next
Set oTables = ActiveDocument.Tables
On Error GoTo 0
Title = "Apply Uniform Borders to All Tables"
If Not Selection.Information(wdWithInTable) Then oTables(1).Select
If oTables.Count > 0 Then
If MsgBox("This command applies uniform table borders and shading " & _
"to all tables in the active document." & vbCr & vbCr & _
"Do you want to continue?", vbQuestion + vbYesNo, Title) = vbYes
Then
LineWeights = Array(wdLineWidth025pt, wdLineWidth050pt, _
wdLineWidth075pt, wdLineWidth100pt, _
wdLineWidth150pt, wdLineWidth225pt, _
wdLineWidth300pt, wdLineWidth450pt, _
wdLineWidth600pt)
Err_ReEntry:
With Dialogs(wdDialogFormatBordersAndShading)
If .Display <> 0 Then
Shadow = .Shadow
'Shading = .Shading
Shading = ConvertShading(.Shading)
On Error GoTo Error_Handler
If Shading = "No VBA conversion" Then
Err.Raise vbObjectError + 1
End If
ForegroundRGB = .ForegroundRGB
BackgroundRGB = .BackgroundRGB
LeftStyle = .LeftStyle
RightStyle = .RightStyle
TopStyle = .TopStyle
BottomStyle = .BottomStyle
HorizStyle = .HorizStyle
VertStyle = .VertStyle
TL2BRStyle = .TL2BRStyle
TR2BLStyle = .TR2BLStyle
TopColorRGB = .TopColorRGB
LeftColorRGB = .LeftColorRGB
BottomColorRGB = .BottomColorRGB
RightColorRGB = .RightColorRGB
HorizColorRGB = .HorizColorRGB
VertColorRGB = .VertColorRGB
TL2BRColorRGB = .TL2BRColorRGB
TR2BLColorRGB = .TR2BLColorRGB
On Error Resume Next
TopWeight = .TopWeight
' LeftWeight = .LeftWeight
' BottomWeight = .BottomWeight
' RightWeight = .RightWeight
' HorizWeight = .HorizWeight
' VertWeight = .VertWeight
' TL2BRWeight = .TL2BRWeight
' TR2BLWeight = .TR2BLWeight
TopWeight = LineWeights(.TopWeight)
LeftWeight = LineWeights(.LeftWeight)
BottomWeight = LineWeights(.BottomWeight)
RightWeight = LineWeights(.RightWeight)
HorizWeight = LineWeights(.HorizWeight)
VertWeight = LineWeights(.VertWeight)
TL2BRWeight = LineWeights(.TL2BRWeight)
TR2BLWeight = LineWeights(.TR2BLWeight)
On Error GoTo 0
End If
End With
For Each oTable In oTables
Application.ScreenRefresh
'Count tables - used in message
n = n + 1
With oTable
' .Select
' With Application.Dialogs(wdDialogFormatBordersAndShading)
' .ApplyTo = 2
' .Shadow = Shadow
' .Shading = Shading
' .ForegroundRGB = ForegroundRGB
' .BackgroundRGB = BackgroundRGB
' .LeftStyle = LeftStyle
' .RightStyle = RightStyle
' .TopStyle = TopStyle
' .BottomStyle = BottomStyle
' .HorizStyle = HorizStyle
' .VertStyle = VertStyle
' .TL2BRStyle = TL2BRStyle
' .TR2BLStyle = TR2BLStyle
' .TopColorRGB = TopColorRGB
' .LeftColorRGB = LeftColorRGB
' .BottomColorRGB = BottomColorRGB
' .RightColorRGB = RightColorRGB
' .HorizColorRGB = HorizColorRGB
' .VertColorRGB = VertColorRGB
' .TL2BRColorRGB = TL2BRColorRGB
' .TR2BLColorRGB = TR2BLColorRGB
' .TopWeight = TopWeight
' .LeftWeight = LeftWeight
' .BottomWeight = BottomWeight
' .RightWeight = RightWeight
' .HorizWeight = HorizWeight
' .VertWeight = VertWeight
' .TL2BRWeight = TL2BRWeight
' .TR2BLWeight = TR2BLWeight
' .Execute
' End With
With .Shading
.ForegroundPatternColor = ForegroundRGB
.BackgroundPatternColor = BackgroundRGB
.Texture = Shading
End With
On Error Resume Next
With .Borders(wdBorderLeft)
.LineStyle = LeftStyle
.LineWidth = LeftWeight
.Color = LeftColorRGB
End With
With .Borders(wdBorderRight)
.LineStyle = RightStyle
.LineWidth = RightWeight
.Color = RightColorRGB
End With
With .Borders(wdBorderTop)
.LineStyle = TopStyle
.LineWidth = TopWeight
.Color = TopColorRGB
End With
With .Borders(wdBorderBottom)
.LineStyle = BottomStyle
.LineWidth = BottomWeight
.Color = BottomColorRGB
End With
With .Borders(wdBorderHorizontal)
.LineStyle = HorizStyle
.LineWidth = HorizWeight
.Color = HorizColorRGB
End With
With .Borders(wdBorderVertical)
.LineStyle = VertStyle
.LineWidth = VertWeight
.Color = VertColorRGB
End With
With .Borders(wdBorderDiagonalUp)
.LineStyle = TR2BLStyle
.LineWidth = TR2BLWeight
.Color = TR2BLColorRGB
End With
With .Borders(wdBorderDiagonalDown)
.LineStyle = TL2BRStyle
.LineWidth = TL2BRWeight
.Color = TL2BRColorRGB
End With
On Error GoTo 0
.Borders.Shadow = Shadow
End With
Next oTable
Application.ScreenRefresh
MsgBox "Finished applying borders to " & n & " tables.", vbOKOnly, Title
Else
'Stop if user did not click Yes
Exit Sub
End If
Else
'Stop - no tables are found
MsgBox "The document contains no tables.", vbInformation, Title
End If
Exit Sub
Error_Handler:
If Err.Number = vbObjectError + 1 Then
MsgBox "This texture setting is unavailable for this process.", vbOKOnly,
"Texture Unavailable"
Resume Err_ReEntry
End If
End Sub
Function ConvertShading(ByRef ShadingSel As Long)
Dim lngVar
Dim Shading
MsgBox ShadingSel
Shading = Array(wdTextureNone, wdTextureSolid, wdTexture5Percent, _
wdTexture10Percent, wdTexture20Percent, wdTexture25Percent,
_
wdTexture30Percent, wdTexture40Percent, wdTexture50Percent,
_
wdTexture60Percent, wdTexture70Percent, wdTexture75Percent,
_
wdTexture80Percent, wdTexture90Percent,
wdTextureDarkHorizontal, _
wdTextureDarkVertical, wdTextureDarkDiagonalDown, _
wdTextureDarkDiagonalUp, wdTextureDarkCross, _
wdTextureDarkDiagonalCross, wdTextureHorizontal,
wdTextureVertical, _
wdTextureDiagonalDown, wdTextureDiagonalUp, wdTextureCross,
_
wdTextureDiagonalCross)
Select Case ShadingSel
Case -1
lngVar = InputBox("VBA can not directly convert your texture selection."
& vbCr + vbCr _
& "Please enter the texture percentage value you selected in
the" & _
" space provided.", "Input Texture Percentage")
Select Case lngVar
Case 12.5, 15, 35, 45, 55, 62.5, 65, 85, 87.5, 95
ConvertShading = 10 * lngVar
Case Else
ConvertShading = "No VBA conversion"
End Select
Case Else
ConvertShading = Shading(ShadingSel)
End Select
End Function

 

[Greg Maxey]

Jay,

It looks like the quickest method is to not use arrays at all but stay with
the built in dialog. There is still the issue of several of the texture
selection returning -1 but I think I have a work around figured out. Here
is the code for using an instance of the borderandshading dialog to perform
the formatting. Only when one of those -1 values are selected as the
texture do I need to convert that to a meaninful value and use the table
object itself:

Public Sub ApplyUniformBordersAndShadingToAllTables()
Dim oTables As Tables
Dim oTable As Table
Dim Title As String
Dim n As Long, i As Long
Dim Shading As Long, ShadingModified As Long, Shadow
Dim TopStyle As Long, LeftStyle As Long, BottomStyle As Long
Dim RightStyle As Long, HorizStyle As Long, VertStyle As Long
Dim TL2BRStyle As Long, TR2BLStyle As Long
Dim TopWeight As Long, LeftWeight As Long, BottomWeight As Long
Dim RightWeight As Long, HorizWeight As Long, VertWeight As Long
Dim TL2BRWeight As Long, TR2BLWeight As Long
Dim ForegroundRGB, BackgroundRGB
Dim TopColorRGB, LeftColorRGB, BottomColorRGB
Dim RightColorRGB, HorizColorRGB, VertColorRGB
Dim TL2BRColorRGB, TR2BLColorRGB
On Error Resume Next
Set oTables = ActiveDocument.Tables
On Error GoTo 0
Title = "Apply Uniform Borders to All Tables"
If Not Selection.Information(wdWithInTable) Then oTables(1).Select
If oTables.Count > 0 Then
If MsgBox("This command applies uniform table borders and shading " & _
"to all tables in the active document." & vbCr & vbCr & _
"Do you want to continue?", vbQuestion + vbYesNo, Title) = vbYes
Then
Err_ReEntry:
With Dialogs(wdDialogFormatBordersAndShading)
If .Display <> 0 Then
Shadow = .Shadow
Shading = .Shading
ForegroundRGB = .ForegroundRGB
BackgroundRGB = .BackgroundRGB
LeftStyle = .LeftStyle
RightStyle = .RightStyle
TopStyle = .TopStyle
BottomStyle = .BottomStyle
HorizStyle = .HorizStyle
VertStyle = .VertStyle
TL2BRStyle = .TL2BRStyle
TR2BLStyle = .TR2BLStyle
TopColorRGB = .TopColorRGB
LeftColorRGB = .LeftColorRGB
BottomColorRGB = .BottomColorRGB
RightColorRGB = .RightColorRGB
HorizColorRGB = .HorizColorRGB
VertColorRGB = .VertColorRGB
TL2BRColorRGB = .TL2BRColorRGB
TR2BLColorRGB = .TR2BLColorRGB
On Error Resume Next
TopWeight = .TopWeight
LeftWeight = .LeftWeight
BottomWeight = .BottomWeight
RightWeight = .RightWeight
HorizWeight = .HorizWeight
VertWeight = .VertWeight
TL2BRWeight = .TL2BRWeight
TR2BLWeight = .TR2BLWeight
TR2BLWeight = .TR2BLWeight
On Error GoTo 0
End If
End With
If Shading = -1 Then
ShadingModified = ConvertShading(Shading)
On Error GoTo Error_Handler
If ShadingModified = 0 Then
Err.Raise vbObjectError + 1
End If
End If
For Each oTable In oTables
Application.ScreenRefresh
'Count tables - used in message
n = n + 1
With oTable
.Select
With Application.Dialogs(wdDialogFormatBordersAndShading)
.ApplyTo = 2
.Shadow = Shadow
If Shading <> -1 Then
.Shading = Shading
End If
.ForegroundRGB = ForegroundRGB
.BackgroundRGB = BackgroundRGB
.LeftStyle = LeftStyle
.RightStyle = RightStyle
.TopStyle = TopStyle
.BottomStyle = BottomStyle
.HorizStyle = HorizStyle
.VertStyle = VertStyle
.TL2BRStyle = TL2BRStyle
.TR2BLStyle = TR2BLStyle
.TopColorRGB = TopColorRGB
.LeftColorRGB = LeftColorRGB
.BottomColorRGB = BottomColorRGB
.RightColorRGB = RightColorRGB
.HorizColorRGB = HorizColorRGB
.VertColorRGB = VertColorRGB
.TL2BRColorRGB = TL2BRColorRGB
.TR2BLColorRGB = TR2BLColorRGB
.TopWeight = TopWeight
.LeftWeight = LeftWeight
.BottomWeight = BottomWeight
.RightWeight = RightWeight
.HorizWeight = HorizWeight
.VertWeight = VertWeight
.TL2BRWeight = TL2BRWeight
.TR2BLWeight = TR2BLWeight
.Execute
End With
If Shading = -1 Then
With .Shading
.ForegroundPatternColor = ForegroundRGB
.BackgroundPatternColor = BackgroundRGB
.Texture = ShadingModified
End With
End If
End With
Next oTable
Application.ScreenRefresh
MsgBox "Finished applying borders to " & n & " tables.", vbOKOnly, Title
Else
'Stop if user did not click Yes
Exit Sub
End If
Else
'Stop - no tables are found
MsgBox "The document contains no tables.", vbInformation, Title
End If
Exit Sub
Error_Handler:
If Err.Number = vbObjectError + 1 Then
MsgBox "This texture setting is unavailable for this process.", vbOKOnly,
"Texture Unavailable"
Resume Err_ReEntry
End If
MsgBox Err.Number & " " & Err.Description
End Sub

Function ConvertShading(ByRef ShadingSel As Long)
Dim lngVar
lngVar = InputBox("VBA can not directly convert your texture selection." &
vbCr + vbCr _
& "Please enter the texture percentage value you selected in
the" & _
" space provided.", "Input Texture Percentage")
Select Case lngVar
Case 12.5, 15, 35, 37.5, 45, 55, 62.5, 65, 85, 87.5, 95
ConvertShading = 10 * lngVar
Case Else
ConvertShading = 0
End Select
End Function