' 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