The following VBA example previews overprinted fills in the drawing by creating additional objects where two or more shapes intersect. These new objects are filled with the appropriate resultant colors. There must be at least two overlapping shapes in the document.
' Previews fill overprints on screen Public Sub CreateOverprint()
Dim n1 As Long
Dim n2 As Long
Dim s1 As Shape
Dim s2 As Shape
Dim s As Shape
Dim shps As Shapes
Dim c1 As New color
Dim c2 As New color
ActiveDocument.ReferencePoint = cdrBottomLeft
ActiveDocument.ShapeEnumDirection = cdrShapeEnumBottomFirst
' Look through all shapes from bottom to top
Set shps = ActivePage.Shapes
For n1 = 1 To shps.Count - 1
Set s1 = shps(n1)
If s1.Fill.Type = cdrUniformFill Then
' If the shape has a uniform fill, get its color
c1.CopyAssign s1.Fill.UniformColor
' Check all shapes above it
For n2 = n1 + 1 To shps.Count
Set s2 = shps(n2)
If s2.Fill.Type = cdrUniformFill And s2.OverprintFill Then
' If the shape has a uniform fill has Overprint fill specified,
' get its color
c2.CopyAssign s2.Fill.UniformColor
If Overlap(s1, s2) Then
' If the shapes may overlap, mix the two colors and ...
MixColors c1, c2
' ... create the intersecting shape
Set s = s1.Intersect(s2)
If Not s Is Nothing Then
' If anything was generated during intersection,
' apply the resulting color to it and mark the shape with
' overprint fill attribute for future processing
s.Fill.ApplyUniformFill c2
s.OverprintFill = True
End If
End If
End If
Next n2
End If
Next n1
End Sub ' Determines if the two shapes may overlap Private Function Overlap(s1 As Shape, s2 As Shape) As Boolean
Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double
Dim x2 As Double, y2 As Double, w2 As Double, h2 As Double
s1.GetBoundingBox x1, y1, w1, h1
s2.GetBoundingBox x2, y2, w2, h2
Overlap = Not (x1 + w1 < x2 Or x2 + w2 < x1 Or y1 + h1 < y2 Or y2 + h2 < y1) End Function ' Mixes two colors according to their inks Private Sub MixColors(c1 As color, c2 As color)
Dim cc1 As New color
Dim bSpot As Boolean
cc1.CopyAssign c1
If cc1.Type <> cdrColorCMYK Then cc1.ConvertToCMYK
bSpot = (c1.Type = cdrColorSpot Or c1.Type = cdrColorPantone Or _
c2.Type = cdrColorSpot Or c2.Type = cdrColorPantone)
If c2.Type <> cdrColorCMYK Then c2.ConvertToCMYK
If Not bSpot Then
' If we are mixing process colors, only replace the color channels that
' have no color in the top shape
If c2.CMYKBlack = 0 Then c2.CMYKBlack = cc1.CMYKBlack
If c2.CMYKCyan = 0 Then c2.CMYKCyan = cc1.CMYKCyan
If c2.CMYKMagenta = 0 Then c2.CMYKMagenta = cc1.CMYKMagenta
If c2.CMYKYellow = 0 Then c2.CMYKYellow = cc1.CMYKYellow
Else
' If we are mixing spot colors, just add inks
c2.CMYKBlack = GetMaxInk(cc1.CMYKBlack + c2.CMYKBlack)
c2.CMYKCyan = GetMaxInk(cc1.CMYKCyan + c2.CMYKCyan)
c2.CMYKMagenta = GetMaxInk(cc1.CMYKMagenta + c2.CMYKMagenta)
c2.CMYKYellow = GetMaxInk(cc1.CMYKYellow + c2.CMYKYellow)
End If
End Sub
' Makes sure the ink level doesn't exceed 100%
Private Function GetMaxInk(Ink As Long) As Long
Dim n As Long
n = Ink
If n > 100 Then n = 100
GetMaxInk = n
End Function