Solved

Get Pixel in VB

Posted on 2001-07-23
21
311 Views
Last Modified: 2010-07-27
Let say I have a small image, 50 by 10.

How do I use VB to get each individual pixel from my image file, and print each pixel
byte to the screen ?
0
Comment
Question by:qetuo088
21 Comments
 
LVL 38

Expert Comment

by:PaulHews
ID: 6309787
There are different ways to do it.

1.  Load a picbox with picture and use Point and Pset
2.  Load a picbox and use GetPoint, SetPoint API (faster)
3.  If it is a BMP, you can retrieve the individual pixels with the API GetDIBits.

Let me know which way you want to do it.
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6309793
>2.  Load a picbox and use GetPoint, SetPoint API (faster)

GetPixel, SetPixel is what that should read.
0
 

Author Comment

by:qetuo088
ID: 6309807
any sample ?
0
 

Author Comment

by:qetuo088
ID: 6309827
I think I will use GetDlBits
0
 
LVL 20

Expert Comment

by:hes
ID: 6309844
0
 

Author Comment

by:qetuo088
ID: 6309867
hes,

that example will not work, becaue what I need is a pixel unit. And I can get a byte
that represents the pixel
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6310216
Here you go.

Option Explicit

Private Type BITMAPFILEHEADER
   bfType As String * 2
   bfSize As Long
   bfReserved1 As Integer
   bfReserved2 As Integer
   bfOffBits As Long
End Type

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Private Type BITMAP  '24 bytes
 bmType As Long
 bmWidth As Long
 bmHeight As Long
 bmWidthBytes As Long
 bmPlanes As Integer
 bmBitsPixel As Integer
 bmBits As Long
End Type

Private Type BITMAPINFO
   bmiHeader As BITMAPINFOHEADER
   bmiColors As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage 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 Const DIB_RGB_COLORS& = 0
Private Const BI_RGB = 0&




Private Sub Form_Load()
   Dim lngRet As Long
   Dim bih As BITMAPINFO
   Dim hCmpDC As Long
   Dim bmp As BITMAP
   Dim lngW As Long, lngH As Long
   Dim hBMP As Long, hOld As Long
   Dim lngColor() As Long
   Dim BytesPerScanLine As Long
   Dim PadBytesPerScanLine As Long
   Dim pic As StdPicture
   Dim i As Long
'   Dim BFH As BITMAPFILEHEADER  'Size 14






       Set pic = LoadPicture("C:\My Documents\Graphics\BMPs\tslogo3d1.bmp")
       hBMP = pic.Handle
   '    Fill out the BITMAP structure.
       lngRet = GetObject(hBMP, Len(bmp), bmp)
       Debug.Print lngRet
       'Create a device context compatible with the Desktop.
       hCmpDC = CreateCompatibleDC(0&)

       'Select the bitmap handle into the new device context.
       hOld = SelectObject(hCmpDC, hBMP)



   With bih.bmiHeader
       .biSize = 40
       .biWidth = bmp.bmWidth
       .biHeight = bmp.bmHeight
       .biPlanes = 1
       .biBitCount = 32
       .biCompression = BI_RGB
       BytesPerScanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
       PadBytesPerScanLine = BytesPerScanLine - (((.biWidth * .biBitCount) + 7) \ 8)
       .biSizeImage = BytesPerScanLine * Abs(.biHeight)

 End With


   ReDim lngColor(1 To bmp.bmWidth * bmp.bmHeight)

   lngRet = GetDIBits(hCmpDC, hBMP, 0, bmp.bmHeight, lngColor(1), bih, DIB_RGB_COLORS)
   Debug.Print lngRet

   Picture1.ScaleMode = vbPixels
   Picture1.Width = bmp.bmWidth * Screen.TwipsPerPixelX
   Picture1.Height = bmp.bmHeight * Screen.TwipsPerPixelY
   Picture1.AutoRedraw = True
   Debug.Print bmp.bmHeight, bmp.bmWidth

   'Write pixels one by one
   
    For lngH = bmp.bmHeight - 1 To 0 Step -1
        For lngW = 0 To bmp.bmWidth - 1
            i = i + 1
            SetPixel Picture1.hdc, lngW, lngH, lngColor(i)
           
        Next
    Next





    'Clean up
   SelectObject hCmpDC, hOld
   DeleteObject hBMP
   DeleteDC hCmpDC



End Sub


0
 

Author Comment

by:qetuo088
ID: 6310678
PaulHews,

You code will make a copy pixel by pixel to picture1, right. But what I want is to print out the byte that represents exach pixel.

For example, here are the first 5 bytes :

 23 4e 3f ff 2e

23 maybe mean blue, ff mean black,  etc.
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6310824
That's easy enough.  I've shown you how to split the long rgb value into r, g, b components.  You can figure out how to do the printing your own way:

Option Explicit

Private Type BITMAPFILEHEADER
   bfType As String * 2
   bfSize As Long
   bfReserved1 As Integer
   bfReserved2 As Integer
   bfOffBits As Long
End Type

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Private Type BITMAP  '24 bytes
 bmType As Long
 bmWidth As Long
 bmHeight As Long
 bmWidthBytes As Long
 bmPlanes As Integer
 bmBitsPixel As Integer
 bmBits As Long
End Type

Private Type BITMAPINFO
   bmiHeader As BITMAPINFOHEADER
   bmiColors As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage 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 Const DIB_RGB_COLORS& = 0
Private Const BI_RGB = 0&

Private Type Lng
    Color As Long
End Type

Private Type Byts
    r As Byte
    g As Byte
    b As Byte
    F As Byte
End Type

Private Sub sSplitRGB(lngColour As Long, r As Byte, g As Byte, b As Byte)


    Dim ColourLng As Lng
    Dim RGBByt As Byts
   
    ColourLng.Color = lngColour
   
    LSet RGBByt = ColourLng
   
    r = RGBByt.r
    g = RGBByt.g
    b = RGBByt.b

End Sub


Private Sub Form_Load()
   Dim lngRet As Long
   Dim bih As BITMAPINFO
   Dim hCmpDC As Long
   Dim bmp As BITMAP
   Dim lngW As Long, lngH As Long
   Dim hBMP As Long, hOld As Long
   Dim lngColor() As Long, r As Byte, g As Byte, b As Byte
   Dim BytesPerScanLine As Long
   Dim PadBytesPerScanLine As Long
   Dim pic As StdPicture
   Dim i As Long
'   Dim BFH As BITMAPFILEHEADER  'Size 14






       Set pic = LoadPicture("C:\My Documents\Graphics\BMPs\tslogo3d1.bmp")
       hBMP = pic.Handle
   '    Fill out the BITMAP structure.
       lngRet = GetObject(hBMP, Len(bmp), bmp)
       Debug.Print lngRet
       'Create a device context compatible with the Desktop.
       hCmpDC = CreateCompatibleDC(0&)

       'Select the bitmap handle into the new device context.
       hOld = SelectObject(hCmpDC, hBMP)



   With bih.bmiHeader
       .biSize = 40
       .biWidth = bmp.bmWidth
       .biHeight = bmp.bmHeight
       .biPlanes = 1
       .biBitCount = 32
       .biCompression = BI_RGB
       BytesPerScanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
       PadBytesPerScanLine = BytesPerScanLine - (((.biWidth * .biBitCount) + 7) \ 8)
       .biSizeImage = BytesPerScanLine * Abs(.biHeight)

 End With


   ReDim lngColor(1 To bmp.bmWidth * bmp.bmHeight)

   lngRet = GetDIBits(hCmpDC, hBMP, 0, bmp.bmHeight, lngColor(1), bih, DIB_RGB_COLORS)
   Debug.Print lngRet

   Picture1.ScaleMode = vbPixels
   Picture1.Width = bmp.bmWidth * Screen.TwipsPerPixelX + 300
   Picture1.Height = bmp.bmHeight * Screen.TwipsPerPixelY + 300
   Picture1.AutoRedraw = True
   Debug.Print bmp.bmHeight, bmp.bmWidth

   'Write pixels one by one
   
    For lngH = bmp.bmHeight - 1 To 0 Step -1
        For lngW = 0 To bmp.bmWidth - 1
            i = i + 1
'            SetPixel Picture1.hdc, lngW, lngH, lngColor(i)
            Call sSplitRGB(lngColor(i), r, g, b)
            Debug.Print "Red : " & Hex(r) & " Green : " & Hex(g) & " Blue : " & Hex(b)
        Next
    Next





    'Clean up
   SelectObject hCmpDC, hOld
   DeleteObject hBMP
   DeleteDC hCmpDC



End Sub


0
 

Author Comment

by:qetuo088
ID: 6310955
PaulHews,

Why I always got lngColour = -1 ?
Shouldn't I get something like 17234132 ?

And When you use debug.print..., I only see a lot of
duplicate lines :

 Red : ff Green : ff Blue : ff

Why ???
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 38

Expert Comment

by:PaulHews
ID: 6310964
Did you copy and paste the code?  Why don't you send me your test bmp and I'll try it? (email in profile)
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6310994
It's because your test bitmap is all black and white (mostly white.)  White in RGB is -1 (FF FF FF), black is 0 (00 00 00)

When I ran your bitmap, I got sections like this:

Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : 0 Green : 0 Blue : 0
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : 0 Green : 0 Blue : 0
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : 0 Green : 0 Blue : 0
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF

But mostly FF FF FF (white)
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6310999
You will get other values than -1 and 0, but that is because there is an unused byte in the long that can contain garbage values.
0
 
LVL 3

Expert Comment

by:leojl
ID: 6311470
whooee
0
 

Author Comment

by:qetuo088
ID: 6311922
PaulHews,

This is what I got :

Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF
Red : FF Green : FF Blue : FF

 33            52

I got all white !
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6312429
The debug window show more than a few hundred entries (even though over a thousand have been printed.)  Try sending it to a file instead.  Rewrite the pixel writing routine like this:

'Write pixels one by one
    Dim hfile As Integer
    hfile = FreeFile
   
   Open "C:\temp\test.txt" For Output As hfile
   For lngH = bmp.bmHeight - 1 To 0 Step -1
       For lngW = 0 To bmp.bmWidth - 1
           i = i + 1
'            SetPixel Picture1.hdc, lngW, lngH, lngColor(i)
           Call sSplitRGB(lngColor(i), r, g, b)
           Print #hfile, "Red : " & Hex(r) & " Green : " & Hex(g) & " Blue : " & Hex(b)
       Next
   Next
    Close #hfile

Better yet, use a bitmap that has lots of different colors.

0
 

Author Comment

by:qetuo088
ID: 6312517
I cannot use a lot of color. I am only limited to
Black, grey, lightgrey, white.
0
 
LVL 38

Expert Comment

by:PaulHews
ID: 6312541
Well the file output should work anyway.  Why are you doing all this if you don't mind me asking.  It seems like an unusual way to treat a bitmap.
0
 

Author Comment

by:qetuo088
ID: 6312552
Let me test it, and I will get back to you !
0
 

Author Comment

by:qetuo088
ID: 6312954
PaulHews,

I copied the code from Form_Load into a Command1_Click.
When I clicked it, picture1 is empty. Why ?

But after pasted the code back to Form_Load, I could see image in picture1.
0
 
LVL 38

Accepted Solution

by:
PaulHews earned 50 total points
ID: 6313379
Well a Picture1.Refresh should take care of that.  Also, I found a bug that shouldn't affect your grey, white, black pictures but should be fixed anyway.  I forgot that the RGB values are reversed in a bitmap, so you have to split the individual bytes out and reorder them.  Full amended code follows:

Option Explicit

Private Type BITMAPFILEHEADER
  bfType As String * 2
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type

Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type

Private Type BITMAP  '24 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage 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 Const DIB_RGB_COLORS& = 0
Private Const BI_RGB = 0&

Private Type Lng
   Color As Long
End Type

Private Type Byts
   r As Byte
   g As Byte
   b As Byte
   F As Byte
End Type

Private Sub sSplitRGB(lngColour As Long, r As Byte, g As Byte, b As Byte)


   Dim ColourLng As Lng
   Dim RGBByt As Byts
   
   ColourLng.Color = lngColour
   
   LSet RGBByt = ColourLng
   
   r = RGBByt.r
   g = RGBByt.g
   b = RGBByt.b

End Sub



Private Sub Command1_Click()
  Dim lngRet As Long
  Dim bih As BITMAPINFO
  Dim hCmpDC As Long
  Dim bmp As BITMAP
  Dim lngW As Long, lngH As Long
  Dim hBMP As Long, hOld As Long
  Dim lngColor() As Long, r As Byte, g As Byte, b As Byte
  Dim BytesPerScanLine As Long
  Dim PadBytesPerScanLine As Long
  Dim pic As StdPicture
  Dim i As Long
'   Dim BFH As BITMAPFILEHEADER  'Size 14






      Set pic = LoadPicture("C:\My Documents\Graphics\bmps\Bike25.BMP")
      hBMP = pic.Handle
  '    Fill out the BITMAP structure.
      lngRet = GetObject(hBMP, Len(bmp), bmp)
      Debug.Print lngRet
      'Create a device context compatible with the Desktop.
      hCmpDC = CreateCompatibleDC(0&)

      'Select the bitmap handle into the new device context.
      hOld = SelectObject(hCmpDC, hBMP)



  With bih.bmiHeader
      .biSize = 40
      .biWidth = bmp.bmWidth
      .biHeight = bmp.bmHeight
      .biPlanes = 1
      .biBitCount = 32
      .biCompression = BI_RGB
      BytesPerScanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
      PadBytesPerScanLine = BytesPerScanLine - (((.biWidth * .biBitCount) + 7) \ 8)
      .biSizeImage = BytesPerScanLine * Abs(.biHeight)

End With


  ReDim lngColor(1 To bmp.bmWidth * bmp.bmHeight)

  lngRet = GetDIBits(hCmpDC, hBMP, 0, bmp.bmHeight, lngColor(1), bih, DIB_RGB_COLORS)
  Debug.Print lngRet

  Picture1.ScaleMode = vbPixels
  Picture1.Width = bmp.bmWidth * Screen.TwipsPerPixelX
  Picture1.Height = bmp.bmHeight * Screen.TwipsPerPixelY
  Picture1.AutoRedraw = True
  Debug.Print bmp.bmHeight, bmp.bmWidth

  'Write pixels one by one
 
   For lngH = bmp.bmHeight - 1 To 0 Step -1
       For lngW = 0 To bmp.bmWidth - 1
           i = i + 1
           Call sSplitRGB(lngColor(i), r, g, b)

           SetPixel Picture1.hdc, lngW, lngH, RGB(b, g, r)
           
       Next
   Next

    Picture1.Refresh




   'Clean up
  SelectObject hCmpDC, hOld
  DeleteObject hBMP
  DeleteDC hCmpDC

End Sub

0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now