VBA eyedropper using excel

[nic]

Having seen pics made in Excel by colouring cells background colours from a bitmap, I have hashed together a coreldraw macro that might do something like the eyedropper tool in vba.

Its not pretty - Im hoping that somebody that knows what they are doing will get it to work right but it will do as a proof of concept.

Im using Excel 2016 and Draw X7
in excel I have the following code; (Found here http://www.nielshorn.net/prog/vba/vbaXL_bmp2xls.php ) (lots of the lines have commented out but left as I suspect they may be useful to others)

Option Explicit

'*** Original C struct:
'typedef struct {
'   unsigned short int type;                 /* Magic identifier            */
'   unsigned int size;                       /* File size in bytes          */
'   unsigned short int reserved1, reserved2;
'   unsigned int offset;                     /* Offset to image data, bytes */
'} HEADER;
Private Type typHeader
    Tipo As String * 2
    Tamanho As Long
    res1 As Integer
    res2 As Integer
    Offset As Long
End Type

'*** Original C struct:
'typedef struct {
'   unsigned int size;               /* Header size in bytes      */
'   int width,height;                /* Width and height of image */
'   unsigned short int planes;       /* Number of colour planes   */
'   unsigned short int bits;         /* Bits per pixel            */
'   unsigned int compression;        /* Compression type          */
'   unsigned int imagesize;          /* Image size in bytes       */
'   int xresolution,yresolution;     /* Pixels per meter          */
'   unsigned int ncolours;           /* Number of colours         */
'   unsigned int importantcolours;   /* Important colours         */
'} INFOHEADER;
Private Type typInfoHeader
    Tamanho As Long
    Largura As Long
    Altura As Long
    Planes As Integer
    Bits As Integer
    Compression As Long
    ImageSize As Long
    xResolution As Long
    yResolution As Long
    nColors As Long
    ImportantColors As Long
End Type

Private Type typePixel
    b As Byte
    g As Byte
    r As Byte
End Type

Sub Desenho()

    Dim bmpHeader As typHeader
    Dim bmpInfoHeader As typInfoHeader
    Dim bmpPixel As typePixel
    
    Dim nCnt As Long
    Dim nRow As Integer, nCol As Integer
    Dim nRowBytes As Long
    
    Dim fBMP As String
    Application.ScreenUpdating = False
    Worksheets(1).Activate
    Columns("A:IV").Delete
    
    fBMP = Workbooks(1).Path & "\" & "Sample2.BMP"
    
    Open fBMP For Binary Access Read As 1 Len = 1
    
        Get 1, 1, bmpHeader
        
        'If bmpHeader.Tipo <> "BMP" Then
         '   MsgBox "Not a bitmap file.", vbCritical, "Error"
          '  End
       ' End If
        
        Get 1, , bmpInfoHeader
        
        If bmpInfoHeader.Bits <> 24 Then
            MsgBox "Sorry, only 24-bits BMP files can be converted.", vbCritical, "Error"
            End
        End If
        If bmpInfoHeader.Compression <> 0 Then
            MsgBox "Sorry, only uncompressed BMP files can be converted.", vbCritical, "Error"
            End
        End If
       ' If bmpInfoHeader.Largura > 255 Or bmpInfoHeader.Altura > 1000 Then
        '   MsgBox "Image is " & bmpInfoHeader.Largura & " x " & _
        '        bmpInfoHeader.Altura & " pixels." & vbCrLf & _
        '        "Maximum size is 255 x 1000.", vbCritical, "Error"
        '    End
      '  End If
        
        Rows("1:" & bmpInfoHeader.Altura).RowHeight = 2
        nRowBytes = bmpInfoHeader.Largura * 3
        If nRowBytes Mod 4 <> 0 Then
            nRowBytes = nRowBytes + (4 - nRowBytes Mod 4)
        End If
        
        'Start actual conversion, reading each pixel...
        For nRow = 0 To bmpInfoHeader.Altura - 1
            'Rows(nRow).RowHeight = 2
            For nCol = 0 To bmpInfoHeader.Largura - 1
                'If nRow = 0 Then
                 '   Columns(nCol + 1).ColumnWidth = 0.17
                'End If
                Get 1, bmpHeader.Offset + 1 + nRow * nRowBytes + nCol * 3, bmpPixel
                Get 1, , bmpPixel
                Cells(bmpInfoHeader.Altura - nRow, nCol + 1).Interior.Color = RGB(bmpPixel.r, bmpPixel.g, bmpPixel.b)
                Cells(bmpInfoHeader.Altura - nRow, nCol + 1).Value = bmpPixel.r & ", " & bmpPixel.g & ", " & bmpPixel.b
              
                Next
        Next
        
    Close
    Application.ScreenUpdating = True
   ' Close fBMP
    Cells(1, 1).Select
    
    MsgBox "Image generated", , "Ready"

End Sub

Editing the vba to put the right bmp in and then running Desenho() should give you a bitmpa image in excel with ech cell containg the r,g,b for that cell in a string. Once you have that open a drawing with shapes on a layer that you wish to colour according to the bitmap.
the vba in corel looks like this

Sub colourFromExcel()

Dim sShape As Shape
Dim sr As ShapeRange
Dim xcol As Single, ycol As Single
Dim w As String, one As String
Dim colourArray As Variant
Dim x As Double, y As Double
Dim r As Integer, g As Integer, b As Integer
Dim xx As Double, yy As Double

Set xl = GetObject(, "Excel.Application")
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrCenter

Set sr = ActiveLayer.Shapes.FindShapes()
            
For Each sShape In sr
    sShape.GetPosition x, y
' should auto calc this but havnt
    xx = Int(x / 2) + 1
    yy = Int(y / 2) + 1
    w = xl.cells(xx, yy)
    xl.cells(yy, xx).Select
   
        
    colourArray = Split(w, ",")
    r = Val(colourArray(0))
    b = Val(colourArray(1))
    g = Val(colourArray(2))
    
   
        
    sShape.Outline.Color.RGBAssign r, g, b
Next sShape
        
End Sub

If you then run from corel with the top left of the image at 0,0 and with the excel sheet being selected it should colour the outlines according to the bit map.