Your pattern look-up table appears fine, some of the "greys" not perfect but
as close as you'll get. It's quicker for me to roll my own test rather than
go through all yours, FYI here it is, try it in 2007 and earlier versions.


Sub TestPatterns()
' requires Function GetPatEquiv() as posted in the thread by "L_P"

Dim patCell As Long, patCht As Long
Dim i As Long, clr As Long, clrP As Long, cx As Long, cxP As Long
Dim shp As Shape
Dim sr As Series
Dim pt As Point
Dim ver As Long
Dim v

ver = Val(Application.Version)

On Error Resume Next
ActiveSheet.ChartObjects.Delete
On Error GoTo 0

Call GetTestSeries(sr)

v = Array("dummy", 1, -4126, -4125, -4124, 17, 18, -4128, -4166, _
-4121, -4162, 9, 10, 11, 12, 13, 14, 15, 16)
For i = 1 To 18

With Cells(1, i)
patCell = v(i)

With .Resize(2).Interior
.Pattern = patCell
.Color = Int(Rnd * 16777215)
.PatternColor = Int(Rnd * 16777215)
cx = .ColorIndex
cxP = .PatternColorIndex

clr = .Color
clrP = .PatternColor

End With

patCht = GetPatEquiv(patCell)
Set pt = sr.Points(i)
If ver = 12 Then
If patCht Then
pt.Fill.Patterned patCht
pt.Format.Fill.ForeColor.RGB = clrP
pt.Format.Fill.BackColor.RGB = clr
Else
pt.Fill.Solid
pt.Format.Fill.ForeColor.RGB = clr
End If

Else
If patCht Then
pt.Fill.Patterned patCht
pt.Fill.ForeColor.SchemeColor = cxP
pt.Fill.BackColor.SchemeColor = cx
Else
pt.Fill.Solid
pt.Fill.ForeColor.SchemeColor = cx
End If
End If
End With
Next

End Sub


Sub GetTestSeries(sr As Series)
Dim i As Long
Dim cht As Chart

ReDim arr(1 To 18)
For i = 1 To 18
arr(i) = 1
Next
With Range("a3")
Set cht = ActiveSheet.ChartObjects.Add(.Left, .Top, _
.Width * 18, .Height * 20).Chart
End With

Set sr = cht.SeriesCollection.NewSeries
sr.Values = arr

cht.ChartGroups(1).GapWidth = 9
cht.Legend.Delete
With cht.Axes(xlValue)
.MaximumScale = 1
.Delete
End With

End Sub


I didn't look into your Transparency stuff. Don't forget too that it's not
always straightforward to get the cell's "apparent" colours, which may be
layered on top of it's interior RGB colours.

Regards,
Peter T



"L_P" wrote in message
...

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/sh...d.php?t=157914

Microsoft Office Help