Sub ConvertShapesToCMYK()
Dim total&, changed&: total = 0: changed = 0
Dim p As Page, oldP As Page, shapes As New ShapeRange
Set shapes = ActiveSelectionRange: Set oldP = ActivePage
' If MsgBox("[ " + Application.ColorManager.CurrentProfile(clrSeparationPrinter).Name + " ]" + _
' vbNewLine + vbNewLine + "Convert " + IIf(shapes.Count = 0, "WHOLE document", "SELECTED shapes"), _
' vbOKCancel, "Convert to CMYK") <> vbOK Then Exit Sub
boostStart "Convert to CMYK"
If shapes.Count = 0 Then
For Each p In ActiveDocument.Pages
p.Activate: ConvertShapesToCMYKiterate p.FindShapes, total, changed
Next p
oldP.Activate
Else
ConvertShapesToCMYKiterate shapes, total, changed
shapes.CreateSelection
End If
boostFinish endUndoGroup:=True
MsgBox ("Total # shapes selected: " & CStr(total) & vbCr & "RGB objects to CMYK: " & CStr(changed))
End Sub
Private Sub ConvertShapesToCMYKiterate(ByRef scope As ShapeRange, ByRef total&, ByRef changed&)
Dim sh As Shape, fc As FountainColor, notCmyk As Boolean
On Error Resume Next
For Each sh In scope
total = total + 1: notCmyk = False
If Not sh.PowerClip Is Nothing Then ConvertShapesToCMYKiterate sh.PowerClip.shapes.Range, total, changed
If sh.Type = cdrGroupShape Then
ConvertShapesToCMYKiterate sh.shapes.All, total, changed
Else
With sh.Fill
Select Case sh.Fill.Type
Case cdrUniformFill: notCmyk = ConvertColorToCMYK(.UniformColor)
Case cdrFountainFill:
For Each fc In .Fountain.Colors
notCmyk = notCmyk Or ConvertColorToCMYK(fc.Color)
Next
Case cdrPatternFill:
notCmyk = ConvertColorToCMYK(.Pattern.BackColor) Or _
ConvertColorToCMYK(.Pattern.FrontColor)
End Select
End With
End If
If sh.Outline.Type = cdrOutline Then notCmyk = notCmyk Or ConvertColorToCMYK(sh.Outline.Color)
If notCmyk Then changed = changed + 1
Next
End Sub
Private Function ConvertColorToCMYK(c As Color) As Boolean
Select Case c.Type
Case cdrColorCMYK 'nothing, it's OK
Case cdrColorBlackAndWhite: ConvertColorToCMYK = True
c.CMYKAssign 0, 0, 0, IIf(c.IsWhite, 0, 100)
Case cdrColorGray: ConvertColorToCMYK = True
c.CMYKAssign 0, 0, 0, (255 - c.Gray) / 255 * 100
Case Else: c.ConvertToCMYK: ConvertColorToCMYK = True
End Select
End Function
Public Sub boostStart(Optional ByVal unDo$ = "")
If unDo <> "" Then ActiveDocument.BeginCommandGroup unDo
Optimization = True
EventsEnabled = False
ActiveDocument.SaveSettings
ActiveDocument.PreserveSelection = False
End Sub
Public Sub boostFinish(Optional ByVal endUndoGroup% = False)
ActiveDocument.PreserveSelection = True
ActiveDocument.RestoreSettings
EventsEnabled = True
Optimization = False
Application.CorelScript.RedrawScreen
If endUndoGroup Then ActiveDocument.EndCommandGroup
End Sub
?