View Single Post
Old 22-08-2013, 15:24
Joe Joe is offline
Join Date: Nov 2008
Location: Latvia
Posts: 92
Send a message via Skype™ to Joe

Sorry for necromancing, but I happened upon this post while searching for something. There is a way, albeit a REALLY inefficient one - using WinAPI GetPixel calls to get pixel colors from screen and use the color values to determine shape size, for example.

I have been hoping to have a code-driven way to take colors from the document for versions, but no cigar.

So here's some ultra-rough code that does something similar to your example. It could be improved by refining the glyph string and just cleaning up in general:

Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Sub TestIt()

    Textify 5

End Sub

Sub Textify(Size As Double)
    Dim lDC As Long
    lDC = GetWindowDC(0)

    Dim RR, GG, BB
    Dim RRh, GGh, BBh
    Dim strBGR
    Dim strBGRLen
    Dim StartX As Long, StartY As Long
    ActiveDocument.Unit = cdrMillimeter
    Dim S As Shape
    Dim Glyphs() As String
    Glyphs = Split(". _ o b O 9 8 M G")
    'boostStart "LEDalize"
    Set S = ActiveSelection.Shapes.Last
    Dim SR As New ShapeRange, V As Shape
    For X = Size / 2 To S.SizeWidth Step Size
        For Y = Size / 2 To S.SizeHeight Step Size
            ActiveWindow.DocumentToScreen S.LeftX + X + Size / 2, S.BottomY + Y + Size / 2, StartX, StartY
            strBGR = (Hex(GetPixel(lDC, StartX, StartY)))
             strBGRLen = Len(strBGR)

             If strBGRLen < 6 Then
                 For cnt = 1 To 6 - strBGRLen Step 1
                     strBGR = "0" & strBGR
                 Next cnt
             End If
             BBh = VBA.Left(strBGR, 2)
             GGh = Mid(strBGR, 3, 2)
             RRh = VBA.Right(strBGR, 2)
             BB = Val("&H" & BBh)
             GG = Val("&H" & GGh)
             RR = Val("&H" & RRh)

            If Size > 0 Then
                Set V = ActiveVirtualLayer.CreateEllipse2(X, Y, Size / 2)
                V.Fill.UniformColor.RGBAssign RR, GG, BB
                With ActiveLayer.CreateArtisticText(0, 0, Glyphs(1 + V.Fill.UniformColor.HSBBrightness / 40))
                    .SetSize , Size
                    .CenterX = X
                    .CenterY = Y
                End With
                SR.Add V
            End If
        Next Y
    Next X
    ActiveDocument.LogCreateShapeRange SR
    'boostFinish True
End Sub
One way to test it would be to put some art that's about 100x100mm and then run the TestIt bit.
Reply With Quote