Thanks for all the feedback Peter_T. I've been wrestling with it for a
while now, and I think I've got it working. I post my code here so that
other people can benefit from it.
I've got a GetPatEquiv function which translates the pattern codes used
in Interior structure to those used in the Format.Fill structure. These
appear to be the closest approximations in Fill to the patterns used in
the older Interior.
Then I've got a CopyColor routine.
Parameters:
Destination - what is receiving the copied color. In pre-2007, this
should be some structure which includes an "Interior" field. In 2007,
this should be a structure which includes a Format.Fill structure.
Target - the Range which has the desired colors in its Interior field
Transparency - the % transparency to set the destination region under
2007
FakeTransparent - a flag to fake transparency in pre-2007 versions.
It is possible to get a "fake" transparency onto a data series in some
circumstances under prior versions by "pasting a shape" into it. This
only works if the shape is a solid color - if it has a pattern this
doesn't work.
The "catch" I do for this is to treat the special case if we are (a) in
pre-2007, (b) are requesting a transparency and (c) providing a solid
color.
In this case, I set the Target's color not to the Destination but to a
special Shape object I have set aside for the purpose. This takes the
same settings as the 2007 Format.Fill object does. Then I select the
Destination and paste the newly-colored shape into it. Voila.
Code:
--------------------
Private Function GetPatEquiv(OldIndex As Integer)
Select Case OldIndex
Case xlPatternGray75
GetPatEquiv = msoPattern75Percent
Case xlPatternGray50
GetPatEquiv = msoPattern50Percent
Case xlPatternGray25
GetPatEquiv = msoPattern25Percent
Case xlPatternGray16
GetPatEquiv = msoPattern20Percent
Case xlPatternGray8
GetPatEquiv = msoPattern10Percent
Case xlPatternHorizontal
GetPatEquiv = msoPatternDarkHorizontal
Case xlPatternVertical
GetPatEquiv = msoPatternDarkVertical
Case xlPatternDown
GetPatEquiv = msoPatternDarkDownwardDiagonal
Case xlPatternUp
GetPatEquiv = msoPatternDarkUpwardDiagonal
Case xlPatternChecker
GetPatEquiv = msoPatternSmallCheckerBoard
Case xlPatternSemiGray75
GetPatEquiv = msoPatternTrellis
Case xlPatternLightHorizontal
GetPatEquiv = msoPatternLightHorizontal
Case xlPatternLightVertical
GetPatEquiv = msoPatternLightVertical
Case xlPatternLightDown
GetPatEquiv = msoPatternLightDownwardDiagonal
Case xlPatternLightUp
GetPatEquiv = msoPatternLightUpwardDiagonal
Case xlPatternGrid
GetPatEquiv = msoPatternSmallGrid
Case xlPatternCrissCross
GetPatEquiv = msoPattern30Percent
End Select
End Function
Private Sub CopyColor(Destination As Variant, Target As Range, Optional
Transparency As Integer, Optional FakeTransparent As Boolean)
Dim ApplyTo As Variant
Dim TransPatch As Boolean
Dim Solid As Boolean
Dim SelCol As Integer, SelRow As Integer
If (Target.Interior.Pattern = xlPatternNone) Or (Target.Interior.Pattern
= xlPatternSolid) Then
Solid = True
Else
Solid = False
End If
If (Val(Application.Version) < 12) And ((Not FakeTransparent) Or
(Transparency = 0) Or (Not Solid)) Then
Destination.Interior.Pattern = Target.Interior.Pattern
Destination.Interior.PatternColorIndex =
Target.Interior.PatternColorIndex
Destination.Interior.ColorIndex = Target.Interior.ColorIndex
Else
If Val(Application.Version) < 12 Then
TransPatch = True
Set ApplyTo = ActiveSheet.Shapes("Transparency")
Else
TransPatch = False
Set ApplyTo = Destination.Format ' 2007 keeps its editable Fill in here,
not in plain old Fill
End If
If Solid Then
ApplyTo.Fill.ForeColor.RGB = Target.Interior.Color
ApplyTo.Fill.Solid
Else
ApplyTo.Fill.ForeColor.RGB = Target.Interior.PatternColor
ApplyTo.Fill.BackColor.RGB = Target.Interior.Color
ApplyTo.Fill.Patterned GetPatEquiv(Target.Interior.Pattern)
End If
ApplyTo.Fill.Transparency = Transparency / 100
If TransPatch Then
SelCol = Selection.Cells(1, 1).Column
SelRow = Selection.Cells(1, 1).Row
ActiveSheet.Shapes("Transparency").Select
Selection.Copy
Destination.Paste
ActiveSheet.Cells(SelRow, SelCol).Select
End If
End If
End Sub
--------------------
--
L_P
------------------------------------------------------------------------
L_P's Profile: 1286
View this thread:
http://www.thecodecage.com/forumz/showthread.php?t=157914
Microsoft Office Help