by these page VB Graphics Programming: Part 3 (Advanced API): http://www.tannerhelland.com/vb6/vb-...programming-3/
i build a procedure for change image colors. but by some reason isn't working
The VB6 is closed. but it's showed a Windows error window.
error message: ".... the memory can't be read..." and "...the memory can't be writen".
heres the procedure:
Code:
Public Sub SetImageData(ByRef DstPictureBox As PictureBox, ByRef ImageData() As Byte, ByRef OldColor As Long, ByRef NewColor As Long)
Dim X As Long, Y As Long
For X = 0 To bm.bmHeight - 1
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(2, X, Y), ImageData(1, X, Y), ImageData(0, X, Y)) Then
RGBColor = RGBValues(NewColor)
ImageData(2, X, Y) = RGBColor.Red
ImageData(1, X, Y) = RGBColor.Green
ImageData(0, X, Y) = RGBColor.Blue
End If
Next Y
Next X
'Now that we've built the temporary header, we use StretchDIBits to take the data from the ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the StretchDIBits call should be on one continuous line)
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0, 0), bmi, 0, vbSrcCopy
'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
If DstPictureBox.AutoRedraw = True Then
DstPictureBox.Picture = DstPictureBox.Image
DstPictureBox.Refresh
End If
End Sub
Private Function RGBValues(Color As Long) As Color 'find the rgb color values of a color
Dim ReturnColor As Color
With ReturnColor
.Red = Fix(Color And 255)
.Green = Fix((Color And 65535) / 256)
.Blue = Fix(Color / 65536)
End With
RGBValues = ReturnColor
End Function
now heres the project....
i don't know why these error
can anyone help me fix the error?
thanks
Last edited by joaquim; Nov 18th, 2009 at 04:34 PM.
1. In your posted code above, shouldn't the For:Next loop be: For X = 0 to bm.bmWidth-1
2. In your GetImageData, routine you are sizing your array incorrectly which is probably causing the crashes. Number of bytes for each row of a bitmap must be word aligned (divisible by 4). You cannot just assume that the following statement is correct for a 24 bit bitmap. Only if the width of the bitmap is divisible by 4 will it be correct else it will not be.
Code:
' Wrong
ReDim ImageData(0 To 2, 0 To bm.bmWidth - 1, 0 To bm.bmHeight - 1)
' added this function I use to word align any bitmap bit depth
Public Function ByteAlignOnWord(ByVal bitDepth As Byte, ByVal Width As Long) As Long
' function to align any bit depth on dWord boundaries
ByteAlignOnWord = (((Width * bitDepth) + &H1F&) And Not &H1F&) \ &H8&
End Function
' now the ReDim may look like this
ReDim ImageData(0 To 2, 0 To ByteAlignOnWord(24,bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
3. In your GetImageData() routine you should verify that the following line of code does not return zero:
GetObject SrcPictureBox.Image, bmLen, bm
4. Tip: The line "RGBColor = RGBValues(NewColor)" only needs to be executed one time. I would take it out of the loop.
Insomnia is just a byproduct of, "It can't be done"
1. In your posted code above, shouldn't the For:Next loop be: For X = 0 to bm.bmWidth-1
2. In your GetImageData, routine you are sizing your array incorrectly which is probably causing the crashes. Number of bytes for each row of a bitmap must be word aligned (divisible by 4). You cannot just assume that the following statement is correct for a 24 bit bitmap. Only if the width of the bitmap is divisible by 4 will it be correct else it will not be.
Code:
' Wrong
ReDim ImageData(0 To 2, 0 To bm.bmWidth - 1, 0 To bm.bmHeight - 1)
' added this function I use to word align any bitmap bit depth
Public Function ByteAlignOnWord(ByVal bitDepth As Byte, ByVal Width As Long) As Long
' function to align any bit depth on dWord boundaries
ByteAlignOnWord = (((Width * bitDepth) + &H1F&) And Not &H1F&) \ &H8&
End Function
' now the ReDim may look like this
ReDim ImageData(0 To 2, 0 To ByteAlignOnWord(24,bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
3. In your GetImageData() routine you should verify that the following line of code does not return zero:
GetObject SrcPictureBox.Image, bmLen, bm
4. Tip: The line "RGBColor = RGBValues(NewColor)" only needs to be executed one time. I would take it out of the loop.
hi LaVolte
now it's working.... thanks
but i still have not a nice results
my sub(with GetPixel() and SetPixel()), don't give me these result
why?
'Routine to set an image's pixel information from an array dimensioned (rgb, x, y)
Public Sub SetImageData(ByRef DstPictureBox As PictureBox, ByRef ImageData() As Byte, ByRef OldColor As Long, ByRef NewColor As Long)
Dim X As Long, Y As Long
RGBColor = RGBValues(NewColor)
For X = 0 To bm.bmHeight - 1
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(2, X, Y), ImageData(1, X, Y), ImageData(0, X, Y)) Then
ImageData(2, X, Y) = RGBColor.Red
ImageData(1, X, Y) = RGBColor.Green
ImageData(0, X, Y) = RGBColor.Blue
End If
Next Y
Next X
'Now that we've built the temporary header, we use StretchDIBits to take the data from the ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the StretchDIBits call should be on one continuous line)
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0, 0), bmi, 0, vbSrcCopy
'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
If DstPictureBox.AutoRedraw = True Then
DstPictureBox.Picture = DstPictureBox.Image
DstPictureBox.Refresh
End If
End Sub
Code:
'Routine to get an image's pixel information into an array dimensioned (rgb, x, y)
Public Function GetImageData(ByRef SrcPictureBox As PictureBox, ByRef ImageData() As Byte) As Long
'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)
'Calculate the size of the bitmap type (in bytes)
bmLen = Len(bm)
'Get the picture box information from SrcPictureBox and put it into our 'bm' variable
GetObject SrcPictureBox.Image, bmLen, bm
If GetObject(SrcPictureBox.Image, bmLen, bm) = 0 Then
GetImageData = 0
Exit Function
Else
GetImageData = GetObject(SrcPictureBox.Image, bmLen, bm)
End If
'Build a correctly sized array.
ReDim ImageData(0 To 2, 0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
bmi.bmHeader.bmWidth = bm.bmWidth
bmi.bmHeader.bmHeight = bm.bmHeight
'Now that we've completely filled up the 'bmi' variable, we use GetDIBits to take the data from SrcPictureBox and put it into the ImageData() array using the settings we specified in 'bmi'
GetDIBits SrcPictureBox.hDC, SrcPictureBox.Image, 0, bm.bmHeight, ImageData(0, 0, 0), bmi, 0
End Function
my post #3. The 1st item I mentioned. You did not fix that.
Also you are calling this twice: GetObject SrcPictureBox.Image, bmLen, bm
my mistake
i did it now, but still having the same problem
Code:
'Routine to set an image's pixel information from an array dimensioned (rgb, x, y)
Public Sub SetImageData(ByRef DstPictureBox As PictureBox, ByRef ImageData() As Byte, ByRef OldColor As Long, ByRef NewColor As Long)
Dim X As Long, Y As Long
RGBColor = RGBValues(NewColor)
For X = 0 To bm.bmWidth - 1
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(2, X, Y), ImageData(1, X, Y), ImageData(0, X, Y)) Then
ImageData(2, X, Y) = RGBColor.Red
ImageData(1, X, Y) = RGBColor.Green
ImageData(0, X, Y) = RGBColor.Blue
End If
Next Y
Next X
'Now that we've built the temporary header, we use StretchDIBits to take the data from the ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the StretchDIBits call should be on one continuous line)
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0, 0), bmi, 0, vbSrcCopy
'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
If DstPictureBox.AutoRedraw = True Then
DstPictureBox.Picture = DstPictureBox.Image
DstPictureBox.Refresh
End If
End Sub
my post #3. The 1st item I mentioned. You did not fix that.
Also you are calling this twice: GetObject SrcPictureBox.Image, bmLen, bm
Code:
'Routine to get an image's pixel information into an array dimensioned (rgb, x, y)
Public Function GetImageData(ByRef SrcPictureBox As PictureBox, ByRef ImageData() As Byte) As Long
'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)
'Calculate the size of the bitmap type (in bytes)
bmLen = Len(bm)
'Get the picture box information from SrcPictureBox and put it into our 'bm' variable
GetImageData = GetObject(SrcPictureBox.Image, bmLen, bm)
If GetImageData = 0 Then Exit Function
'Build a correctly sized array.
ReDim ImageData(0 To 2, 0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
bmi.bmHeader.bmWidth = bm.bmWidth
bmi.bmHeader.bmHeight = bm.bmHeight
'Now that we've completely filled up the 'bmi' variable, we use GetDIBits to take the data from SrcPictureBox and put it into the ImageData() array using the settings we specified in 'bmi'
GetDIBits SrcPictureBox.hDC, SrcPictureBox.Image, 0, bm.bmHeight, ImageData(0, 0, 0), bmi, 0
End Function
now i fix that
but i still having the pixels problems
Your loop is looping thru only a 3rd of the array. Here are some recommended changes
Code:
Dim X As Long, Y As Long
Dim lScanWidth As Long ' << added
lScanWidth = ByteAlignOnWord(24, bm.bmWidth) ' << added
RGBColor = RGBValues(NewColor)
For X = 0 To lScanWidth - 1 Step 3 ' << modified
....
Insomnia is just a byproduct of, "It can't be done"
Your loop is looping thru only a 3rd of the array. Here are some recommended changes
Code:
Dim X As Long, Y As Long
Dim lScanWidth As Long ' << added
lScanWidth = ByteAlignOnWord(24, bm.bmWidth) ' << added
RGBColor = RGBValues(NewColor)
For X = 0 To lScanWidth - 1 Step 3 ' << modified
....
Yep, your 3D array is throwing my calculations off.
Here is how to do it with a 2D array. You can use this or modify your For:Next loop to work with 3D arrays. Your choice
2D array requires the following line changes
Code:
ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
GetDIBits SrcPictureBox.hDC, SrcPictureBox.Image, 0, bm.bmHeight, ImageData(0, 0), bmi, 0
' replace loop like so:
For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 1 Step 3
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(X, Y), ImageData(X, Y), ImageData(X, Y)) Then
ImageData(X + 2, Y) = RGBColor.Red
ImageData(X + 1, Y) = RGBColor.Green
ImageData(X, Y) = RGBColor.Blue
End If
Next Y
Next X
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0), bmi, 0, vbSrcCopy
Insomnia is just a byproduct of, "It can't be done"
Yep, your 3D array is throwing my calculations off.
Here is how to do it with a 2D array. You can use this or modify your For:Next loop to work with 3D arrays. Your choice
2D array requires the following line changes
Code:
ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
GetDIBits SrcPictureBox.hDC, SrcPictureBox.Image, 0, bm.bmHeight, ImageData(0, 0), bmi, 0
' replace loop like so:
For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 1 Step 3
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(X, Y), ImageData(X, Y), ImageData(X, Y)) Then
ImageData(X + 2, Y) = RGBColor.Red
ImageData(X + 1, Y) = RGBColor.Green
ImageData(X, Y) = RGBColor.Blue
End If
Next Y
Next X
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0), bmi, 0, vbSrcCopy
i'm still having some problems in result
Code:
'Routine to get an image's pixel information into an array dimensioned (rgb, x, y)
Public Function GetImageData(ByRef SrcPictureBox As PictureBox, ByRef ImageData() As Byte) As Long
'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)
'Calculate the size of the bitmap type (in bytes)
bmLen = Len(bm)
'Get the picture box information from SrcPictureBox and put it into our 'bm' variable
GetImageData = GetObject(SrcPictureBox.Image, bmLen, bm)
If GetImageData = 0 Then Exit Function
'Build a correctly sized array.
ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
bmi.bmHeader.bmWidth = bm.bmWidth
bmi.bmHeader.bmHeight = bm.bmHeight
'Now that we've completely filled up the 'bmi' variable, we use GetDIBits to take the data from SrcPictureBox and put it into the ImageData() array using the settings we specified in 'bmi'
GetDIBits SrcPictureBox.hDC, SrcPictureBox.Image, 0, bm.bmHeight, ImageData(0, 0), bmi, 0
End Function
'Routine to set an image's pixel information from an array dimensioned (rgb, x, y)
Public Sub SetImageData(ByRef DstPictureBox As PictureBox, ByRef ImageData() As Byte, ByRef OldColor As Long, ByRef NewColor As Long)
Dim X As Long, Y As Long
RGBColor = RGBValues(NewColor)
For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 1 Step 3
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(X, Y), ImageData(X, Y), ImageData(X, Y)) Then
ImageData(X + 2, Y) = RGBColor.Red
ImageData(X + 1, Y) = RGBColor.Green
ImageData(X, Y) = RGBColor.Blue
End If
Next Y
Next X
'Now that we've built the temporary header, we use StretchDIBits to take the data from the ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the StretchDIBits call should be on one continuous line)
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0), bmi, 0, vbSrcCopy
'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
If DstPictureBox.AutoRedraw = True Then
DstPictureBox.Picture = DstPictureBox.Image
DstPictureBox.Refresh
End If
End Sub
see the image result.
has you can see, not only the eyes was changed. but some part of the head too
why?
is about the variables types?
oldcolor and newcolor are long, and ImageData() is byte.
heres how i use it:
Code:
Private Sub Command1_Click()
Dim imgData() As Byte
GetImageData Picture1, imgData()
SetImageData Picture2, imgData(), Picture3.BackColor, Picture4.BackColor
End Sub
Last edited by joaquim; Nov 19th, 2009 at 04:51 PM.
i can do it(with a correct result) with these sub:
Code:
Public Sub ChangeColor(Picture As Object, OldColor As Long, NewColor As Long)
Dim mDC As Long
Dim mBMP As Long
Dim PosX As Long
Dim PosY As Long
Dim PixelColor As Long
Dim ScaleMode As Integer
Dim AutoRedraw As Boolean
ScaleMode = Picture.ScaleMode
Picture.ScaleMode = 3
AutoRedraw = Picture.AutoRedraw
Picture.AutoRedraw = True
mDC = CreateCompatibleDC(Picture.hdc)
mBMP = CreateCompatibleBitmap(Picture.hdc, Picture.ScaleWidth, Picture.ScaleHeight)
SelectObject mDC, mBMP
BitBlt mDC, 0, 0, Picture.ScaleWidth, Picture.ScaleHeight, Picture.hdc, 0, 0, vbSrcCopy
For PosX = 0 To Picture.ScaleWidth
For PosY = 0 To Picture.ScaleHeight
PixelColor = GetPixel(mDC, PosX, PosY)
If PixelColor <> -1 Then
If PixelColor = OldColor Then
SetPixel mDC, PosX, PosY, NewColor
End If
End If
Next PosY
Next PosX
BitBlt Picture.hdc, 0, 0, Picture.ScaleWidth, Picture.ScaleHeight, mDC, 0, 0, vbSrcCopy
Picture.ScaleMode = ScaleMode
Picture.Picture = Picture.Image
Picture.AutoRedraw = AutoRedraw
DeleteObject mBMP
DeleteDC mDC
End Sub
but i need speed. and the only way is the DIB code
i can control these entire code
do what i need with pixels
but like i said, i want speed
i show you these for you catch more what i mean
thank you for help me my friend... thanks
1. For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
2. If OldColor = RGB(ImageData(X + 2, Y), ImageData(X + 1, Y), ImageData(X, Y)) Then
sorry in 2nd point
i didn't get it
now it's working fine
thanks
now i can working with DIB's easy
Code:
'Routine to set an image's pixel information from an array dimensioned (rgb, x, y)
Public Sub SetImageData(ByRef DstPictureBox As PictureBox, ByRef ImageData() As Byte, ByRef OldColor As Long, ByRef NewColor As Long)
Dim X As Long, Y As Long
RGBColor = RGBValues(NewColor)
For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(X + 2, Y), ImageData(X + 1, Y), ImageData(X, Y)) Then
ImageData(X + 2, Y) = RGBColor.Red
ImageData(X + 1, Y) = RGBColor.Green
ImageData(X, Y) = RGBColor.Blue
End If
Next Y
Next X
'Now that we've built the temporary header, we use StretchDIBits to take the data from the ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the StretchDIBits call should be on one continuous line)
StretchDIBits DstPictureBox.hDC, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0), bmi, 0, vbSrcCopy
'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
If DstPictureBox.AutoRedraw = True Then
DstPictureBox.Picture = DstPictureBox.Image
DstPictureBox.Refresh
End If
End Sub
now i'm trying put it in my Sprite 2D control
but i catch 1 error. before works 100% well, now i catch 1 error
sometimes i don't understand
in a module:
Code:
'Some functions for work with bitmaps\Images
Option Explicit
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte
End Type
Private Type BITMAPINFO
bmHeader As BITMAPINFOHEADER
bmColors(0 To 255) As RGBQUAD
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef 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 BITMAPINFOHEADER, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage As Long) As Long
Private Type Color
Red As Long
Green As Long
Blue As Long
End Type
Dim hbmp As Long
Dim bih As BITMAPINFOHEADER
Dim bmpBits() As Long
Private Const DIB_RGB_COLORS As Long = 0
Public Const SRCCOPY = &HCC0020
'Routine to set an image's pixel information from an array dimensioned (rgb, x, y)
Public Sub DIBChangeImageColor(ByRef SrcPicturebox As PictureBox, ByRef DstPictureBox As PictureBox, ByRef OldColor As Long, ByRef NewColor As Long)
Dim X As Long, Y As Long
Dim ImageData() As Byte
Dim bmLen As Long
Dim bm As BITMAP
Dim bmi As BITMAPINFO
Dim RGBColor As Color
'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
bmi.bmHeader.biSize = 40 'Size, in bytes, of the header (always 40)
bmi.bmHeader.biPlanes = 1 'Number of planes (always one)
bmi.bmHeader.biBitCount = 24 'Bits per pixel (always 24 for image processing)
bmi.bmHeader.biCompression = 0 'Compression: none or RLE (always zero)
'Calculate the size of the bitmap type (in bytes)
bmLen = Len(bm)
GetObject SrcPicturebox.Image, bmLen, bm
'Build a correctly sized array.
ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
bmi.bmHeader.biWidth = bm.bmWidth 'now it's bi and not bm
bmi.bmHeader.biHeight = bm.bmHeight 'now it's bi and not bm
'Now that we've completely filled up the 'bmi' variable, we use GetDIBits to take the data from SrcPictureBox and put it into the ImageData() array using the settings we specified in 'bmi'
GetDIBits SrcPicturebox.hdc, SrcPicturebox.Image, 0, bm.bmHeight, ImageData(0, 0), bmi, 0 'bmi is give me the error:( "byref argument type mismatch"
RGBColor = RGBValues(NewColor)
For X = 0 To ByteAlignOnWord(bmi.bmHeader.biBitCount, bm.biWidth) - 3 Step 3
For Y = 0 To bm.bmHeight - 1
If OldColor = RGB(ImageData(X + 2, Y), ImageData(X + 1, Y), ImageData(X, Y)) Then
ImageData(X + 2, Y) = RGBColor.Red
ImageData(X + 1, Y) = RGBColor.Green
ImageData(X, Y) = RGBColor.Blue
End If
Next Y
Next X
'Now that we've built the temporary header, we use StretchDIBits to take the data from the ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the StretchDIBits call should be on one continuous line)
StretchDIBits DstPictureBox.hdc, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0), bmi, 0, vbSrcCopy
'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
If DstPictureBox.AutoRedraw = True Then
DstPictureBox.Picture = DstPictureBox.Image
DstPictureBox.Refresh
End If
End Sub
please help me correct these last error
in these line:
Code:
GetDIBits SrcPicturebox.hdc, SrcPicturebox.Image, 0, bm.bmHeight, ImageData(0, 0), bmi, 0 'bmi is give me the error:( "byref argument type mismatch"
error message: "compiler error: byref argument type mismatch".
thanks
1. You added: Dim bmi As BITMAPINFO
2. The API has: ... lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage As Long ...
sorry. now i'm building 100% new Graphic module(with your help... thanks) for put in my Sprite control.
now i need to catch the real image size:
Code:
Private Declare Function GetBitmapDimensionEx Lib "gdi32" (ByVal hBitmap As Long, lpDimension As Size) As Long
Private Type Size
cx As Long
cy As Long
End Type
Dim bitmapsize As Size
Public Sub ImageSize(ByRef Picture As Control)
GetBitmapDimensionEx Picture.Picture.Handle, bitmapsize
Debug.Print bitmapsize.cx
End Sub
my problem here is that i only recive 0(zero)
why?
Last edited by joaquim; Nov 21st, 2009 at 01:12 PM.
The GetBitmapDimensionEx function retrieves the dimensions of a compatible bitmap. The retrieved dimensions must have been set by the SetBitmapDimensionEx function
If you are wanting the size of a picture object, use ScaleX/ScaleY
[RESOLVED] [VB6] API DIBs - Change Image Colors
Reply With Quote
Resolved", if the query is solved
Originally Posted by LaVolpe
