Excel - "escribir" píxeles sobre un shape

Esto es lo que tengo.

El programa permite (re)generar la imagen por x (se genera toda una columna), por ordenadas (se generar toda una fila) o por puntos (la imagen se genera punto a punto).

Me falta la rutina para capturar el color del pixel de la imagen que quiero generar. 

Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

' devuelve el device context del area del cliente de la ventana

Private Declare Function GetDC Lib "user32" ( _

                      ByVal hwnd As Long) As Long

' devuelve el device context de toda la ventana

Private Declare Function GetWindowDC Lib "user32" ( _

                      ByVal hwnd As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" ( _

                      ByVal hDC As Long, ByVal nindex As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _

                      ByVal hwnd As Long, ByVal hDC As Long) As Long

Private Declare Function GetPixel Lib "gdi32" ( _

                      ByVal hDC As Long, ByVal x As Long, _

                      ByVal y As Long) As Long

Private Declare Function SetPixel Lib "gdi32" ( _

                      ByVal hDC As Long, ByVal x As Long, _

                      ByVal y As Long, ByVal crColor As Long) As Long

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _

                      ByVal hwnd As Long, _

                      ByVal lpString As String, ByVal cch As Long) As Long

Sub p()

    GenerarCoordenadas 500, 500

    Barajar 500, 500

    GenerarImagen "xy"  ' valores validos x, y, xy

End Sub

Private Sub GenerarImagen(Tipo As String)

    Dim x As Long     ' abscisa

    Dim y As Long     ' ordenada

    Dim hDC As Long   ' handle device context

    Dim hdc1 As Long   ' handle device context

    Dim hExcel As Long

    Dim r As Byte

    Dim g As Byte

    Dim b As Byte

    Dim i As Long

    Dim j As Long

    Dim H As Worksheet

    Dim Color As Long

    Dim hwnd As Long

    Dim rango As Range

    Dim xy() As String

    Set H = Worksheets("Hoja1")

    H.Activate

    hExcel = Application.hwnd

 '    hdc = GetDC(0)   ' consola

    hDC = GetDC(hExcel)

    hdc1 = GetWindowDC(hExcel)

    With H

        Select Case Tipo

            Case "x"

                For i = 2 To .Cells(1, 1).End(xlDown).Row

                    x = .Cells(i, 1)

                    For j = 2 To .Cells(1, 2).End(xlDown).Row

                        y = .Cells(j, 2)

                        Color = GetPixel(hdc1, x + 500, y + 350)

            '            r = Int((256) * Rnd)

            '            g = Int((256) * Rnd)

            '            b = Int((256) * Rnd)

               '         SetPixel hdc, x, y, Color

                        SetPixel hdc1, x + 500, y + 350, vbYellow

                  '      SetPixel hdc, x, y, RGB(r, g, b)

                    Next

                Next

                ReleaseDC 0, hDC

            Case "y"

                For i = 2 To .Cells(1, 2).End(xlDown).Row

                    y = .Cells(i, 1)

                    For j = 2 To .Cells(1, 1).End(xlDown).Row

                        x = .Cells(j, 2)

                        Color = GetPixel(hdc1, x + 500, y + 350)

            '            r = Int((256) * Rnd)

            '            g = Int((256) * Rnd)

            '            b = Int((256) * Rnd)

               '         SetPixel hdc, x, y, Color

                        SetPixel hdc1, x + 500, y + 350, vbYellow

                  '      SetPixel hdc, x, y, RGB(r, g, b)

                    Next

                Next

                ReleaseDC 0, hDC

            Case "xy"

                For i = 2 To .Cells(1, 3).End(xlDown).Row

                    xy = Split(.Cells(i, 3), ";")

                    x = CLng(xy(0))

                    y = CLng(xy(1))

'                    Color = GetPixel(hdc1, x + 500, y + 350)

                    r = Int((256) * Rnd)

                    g = Int((256) * Rnd)

                    b = Int((256) * Rnd)

        '            SetPixel hdc1, x + 500, y + 350, vbYellow

                    SetPixel hdc1, x + 500, y + 350, RGB(r, g, b)

'                    Sleep 10  ' congela la ejecución

                Next

                ReleaseDC 0, hDC

        End Select

    End With

End Sub

Sub Barajar(x As Long, y As Long)

    Dim i As Long

    Dim j As Long

    Dim H As Worksheet

    Dim f1 As Long

    Dim f2 As Long

    Dim Temp As String

    Set H = Worksheets("Hoja1")

    With H

        ' barajo la x

        For i = 2 To .Cells(1, 1).End(xlDown).Row

            f1 = Int(x * Rnd + 2)

            If f1 < 2 Or f1 > x + 1 Then

                MsgBox "parar"

            End If

            Temp = .Cells(i, 1)

            .Cells(i, 1) = .Cells(f1, 1)

            .Cells(f1, 1) = Temp

        Next

        ' barajo la y

        For i = 2 To .Cells(1, 2).End(xlDown).Row

            f2 = Int(y * Rnd + 2)

            If f2 < 2 Or f2 > y + 1 Then

                MsgBox "parar"

            End If

            Temp = .Cells(i, 2)

            .Cells(i, 2) = .Cells(f2, 2)

            .Cells(f2, 2) = Temp

        Next

        ' barajo la xy

        For i = 2 To .Cells(1, 3).End(xlDown).Row

            f2 = Int(x * y * Rnd + 2)

            If f2 < 2 Or f2 > x * y + 1 Then

                MsgBox "parar"

            End If

            Temp = .Cells(i, 3)

            .Cells(i, 3) = .Cells(f2, 3)

            .Cells(f2, 3) = Temp

        Next

    End With

End Sub

Sub LeerPixeles()

    Dim H2 As Worksheet

    Dim sh As Shape

    Dim Celda As Range

    Set H2 = Worksheets("Hoja2")

    Set Celda = H2.Cells(1, 1)

    Debug.Print H2.Type

    Debug.Print Celda.Parent.Type

End Sub

Sub GenerarCoordenadas(x As Long, y As Long)

    Dim i As Long

    Dim j As Long

    Dim f As Long

    Dim H As Worksheet

    Set H = Worksheets("Hoja1")

    With H

        ' borro datos anteriores

        .Rows("2:1000000").Delete

        ' coordenadas x

        For i = 1 To x

            .Cells(i + 1, 1) = i

        Next

        ' coordenadas y

        For i = 1 To y

            .Cells(i + 1, 2) = i

        Next

        ' coordenadas xy

        f = 2

        For i = 1 To x

            For j = 1 To y

                .Cells(f, 3) = i & ";" & j

                f = f + 1

            Next

        Next

    End With

End Sub

No es el efecto que busco. 

Quiero que la imagen se construya poco a poco, por "piezas" para mantener la curiosidad.

Yo estoy atascado con la lectura de los píxeles de la imagen original, la escritura creo que ya está resuelta.

El tamaño de la imagen y la posición, no me preocupan, voy a considerar que son fijas y conocidas.

1. independientemente del significado, para proveer el hdc terminas por necesitar del hWnd que (hasta donde se) las shapes incrustadas en hojas no lo tienen (al menos no lo exponen para VBA)
2. hasta donde he podido investigar, la API SetPixel (en VBA) no dispone de un color "transparente"
3. para rastrear pixeles en una shape incrustada en hoja, habría que conocer las dimensiones reales (de la imagen) y la (posible) distorsión de haberla "manipulado" como shape incrustada en la hoja

(ya conoces los factores que intervienen, sin mencionar los que no fueron mencionados en ese mensaje)

desordenar una secuencia de ubicaciones... no le veo mayor inconveniente, el detalle sería proveer la información "correcta" de estos tres puntos (?)

alternativas ?

• usar objetos IE donde puedes mostrar imágenes de varias fuentes y tipos con degradados (opacidad/transparencia)
• usar formularios de usuario (con su hWnd) y mostrar imágenes (en el mismo userform y/o en controles de imagen) y API's para dar transparencia/opacidad el formulario completo
• usar directamente las imágenes incrustadas en la hoja y un poco de código (mas sencillo que las opciones anteriores y otras mas)

ejemplo:

• una imagen incrustada en la hoja: en el ejemplo, la Shapes(2)
• una autoforma (texto o rectángulo) sobrepuesta a la imagen (mismas dimensiones), fondo blanco opaco y sin líneas de contorno: en el ejemplo, la Shapes(3)
• cuando quieras darle a la imagen el efecto descrito en tu post original, ejecutas una macro +/- como la expuesta al final del presente

notas: el código original "era" mas sencillo y con solo la shape de imagen, pero... al probar con versiones diferentes encontré que a partir de la version 2010 ha quedado un BUG que impide que la interfaz de usuario y VBA mantengan comunicación con las modificaciones hechas a las shapes entre usuario y VBA

(lo que hace uno, no "lo ve" el otro, ya ves, no faltan las "pifias" del equipo de desarrollo del excel con las "mejoras" que le van haciendo a las aplicaciones)

cualquier adaptación que le quieras hacer al código, ya va por tu cuenta (necesidad o gusto)

saludos,

hector.

Sub imagenGradual()

  Dim i As Single, n As Single

  With ActiveSheet.Shapes(2).PictureFormat

    .Brightness = 1

    ActiveSheet.Shapes(3).Visible = False

    For i = 1 To 0.5 Step -0.01

      .Brightness = i

      n = Timer + 0.05

      Do While n > Timer

        DoEvents

      Loop

    Next

  End With

  Application.Wait Now + TimeSerial(0, 0, 3)

  ActiveSheet.Shapes(3).Visible = True

End Sub

1. No lo sé. hdc es el handle device context (no es el handle de la ventana (hwnd). Estoy en fase de estudio. a unas malas, lo haré sobre un userform que ésos sí tiene hdc (creo recordar).

El hwnd de la ventana de excel puedes obtenerlo asi: hExcel=application(hwnd) y el hdc de la ventana de excel así: hdc = GetDC(hExcel). 

2. Tampoco lo sé. Esa opción no la he investigado todavía, sería como "enviar al fondo" pero sólo un píxel.
3. esta sí la sé. Lo hago así: En un columna escribo la coordenada x (por ejemplo los numeros 0 hasta 1000), en otra columna escribo la coordenada y (p.e. desde 0 hasta 500). Después "barajo" los datos.

Y ya está, sólo tengo que leer secuencialmente las dos columnas para obtener las coordenadas del pixel que he de leer en la foto (para obtener el color) y después escribir en la shape, en esa coordenada el color leído.

Por cierto, que Excel no tiene una función "desordenar". La he echado de menos.

Es muy raro que ningún moderador haya sugerido que la consulta se haga en otro foro "más técnico".

ya hiciste tus pruebas ?, yo tengo varias alternativas (casi listas) pero te pasaré la mas sencilla luego de que me contestes lo siguiente:

1. como piensas obtener el manejador de ventana de una "shape" incrustada en una hoja de calculo para proveer el "hdc" a las API's de los pixeles ?
2. cual es el truco (si existe para VBA) para que la API SetPixel aplique un color transparente ?
3. como piensas aplicar alguna aleatoriedad a los pixeles de la shape en el relleno de la imagen ?

saludos,

hector.