Good afternoon dear community,
I was wondering if there is a genius out there prepared to assist me or lead me in the right direction?So i need to sample 4 or 5 colors per digital proof that is sent out to customers.I need to sample the color from the X,Y coordinates of the "GetUserClick", then automatically create an "artistictext" layer which is placed to the right of the "getUserClick" to location "x140+5" and the CMYK value from the "getuserclick" location should then be pasted into this artistictext layer.I have managed to do this from an object that is filled with a solid color; however cannot seem to figure out how to do this with a bitmap? - is it possible?Any assistance in this regard would be greatly appreciated!Kind regards,keith.
You are a legend! Thank you so much for this.I am going to combine your code with the a line segment creator, and a text box creator to indicate the sampled area and display the sampled color value for our digital proofs that get sent out. The guys are spending hours every day doing this manually so this is going to be amazing once it's done! Below is what i have thus far; posting just incase there is something in there that you might want or would like to use in the future :) Thanks again for all your help---Creating a Line Segment---
Sub LineSegment() 'Create line at specified location on specified layer Dim sh As Shape, sr As ShapeRange ActiveDocument.Unit = cdrMillimeter ActivePage.Layers("Color Indicator Lines").Activate Set sh = ActiveLayer.CreateLineSegment(1, 1, 5, 1) 'StartX, StartY, EndX, EndY Set sh = ActiveLayers.StartArrowHead(56)
End Sub---Creating ArrowHeads on Line---Sub ItemArrowHead() 'Setting active selection ArrowHead Type Dim s As Shape For Each s In ActiveDocument.Selection.Shapes If s.Outline.Type = cdrOutline Then s.Outline.StartArrow = ArrowHeads.Item(53) 'can also be referenced as s.Outline.StartArrow = ArrowHeads(53) End If Next s
End Sub---Creating Text box from samplepoint----
Sub ProofColour()Dim x#, y#Dim x1#, y1#, w1#, h1#Dim Shift As LongDim b As BooleanDim s As ShapeDim textUnder As ShapeDim textStr2 As String
ActiveDocument.Unit = cdrMillimeter
On Error GoTo 1000b = FalseWhile Not b b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorEyeDrop) If Not b Then Set s = ActivePage.SelectShapesAtPoint(x, y, True) If s.Fill.UniformColor.IsCMYK Then textStr2 = s.Fill.UniformColor.CMYKCyan & "/" & s.Fill.UniformColor.CMYKMagenta & "/" & _ s.Fill.UniformColor.CMYKYellow & "/" & s.Fill.UniformColor.CMYKBlack End If s.GetBoundingBox x1, y1, w1, h1 Set textUnder = ActiveLayer.CreateArtisticText(x1 + (w1 + 3.5), (y1 + 0.7), textStr2, , , , 10.16) s.Fill.UniformColor.CMYKAssign 0, 100, 100, 0 s.MoveToLayer ActivePage.Layers("Color Specs") End IfWend1000:End Sub