OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 18-04-2016, 10:33
nic nic is offline
Member
 
Join Date: May 2009
Posts: 90
Default VBA eyedropper using excel

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)
Code:
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
Code:
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.

Last edited by nic; 18-04-2016 at 10:42.
Reply With Quote
Reply

Tags
eyedropper excel bitmap


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
x5 eyedropper tool nic CorelDRAW/Corel DESIGNER VBA 4 24-04-2014 15:16
Eyedropper or get color from a bitmap MikeVerDuin Macros/Add-ons 3 19-04-2011 14:57
Working with Excel nic CorelDRAW/Corel DESIGNER VBA 3 03-05-2010 09:00
Eyedropper on Bitmaps LaffRiot CorelDRAW/Corel DESIGNER VBA 1 24-06-2008 23:09
Draw x3 problems - bitmap editing & eyedropper siegbrunn General 3 15-11-2006 13:25


All times are GMT -5. The time now is 23:19.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com