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.
Have you tried using the Document.SampleColorAtPoint method?
After using GetUserClick to get x,y coordinates of a point?
Hey Eskimo
I just started looking into that after I posted ^^,)If i do come right with it, I will revert with working code; so for as long as I do not respond you can assume I have been unsuccessful.
Here's an example where I create a rectangle centered at the sampling point, then apply a uniform fill based on the sampled color:
You Legit make me so jealous!Your skills are insane... hahaha!I google, then copy, then paste, then mix it up for 100 days till i get it to work ^^,)Don't you wanne share a snippit please Eskimo, i will buy you a coffee? lol!
This is what I used for that demonstration:
Sub sample_color_by_click() Dim dblTargetX As Double Dim dblTargetY As Double Dim blnGotClick As Boolean Dim colorSampled As Color Const dblRectDim As Double = 0.5 Dim sRect As Shape Do get_coordinates_from_click dblTargetX, dblTargetY, blnGotClick If blnGotClick Then Set colorSampled = ActiveDocument.SampleColorAtPoint(dblTargetX, dblTargetY) Set sRect = ActiveLayer.CreateRectangle2(dblTargetX - dblRectDim / 2, dblTargetY - dblRectDim / 2, dblRectDim, dblRectDim) sRect.Fill.ApplyUniformFill colorSampled End If Loop While blnGotClick End Sub Sub get_coordinates_from_click(ByRef ClickX As Double, ByRef ClickY As Double, ByRef ClickMade As Boolean) Dim dblClickX As Double Dim dblClickY As Double Dim lngShiftState As Long Const lngTimeout As Long = 10 Const blnSnap As Boolean = True Dim blnCancelled As Boolean blnCancelled = True blnCancelled = ActiveDocument.GetUserClick(dblClickX, dblClickY, lngShiftState, lngTimeout, blnSnap, cdrCursorSmallcrosshair) If blnCancelled = False Then ClickX = dblClickX ClickY = dblClickY ClickMade = True Else ClickMade = False End If End Sub
I used rectangles just as a quick way to check to see what Color I had sampled. You could instead get the information you need from the sampled Color using the appropriate properties and methods.
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