[RESOLVED] [VB6] DIBs Rotate Image
in a module i have the 1 DIB RotateImage() sub:
Code:
Option Explicit
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 Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte
End Type
Private Type BITMAPINFOHEADER
bmSize As Long
bmWidth As Long
bmHeight As Long
bmPlanes As Integer
bmBitCount As Integer
bmCompression As Long
bmSizeImage As Long
bmXPelsPerMeter As Long
bmYPelsPerMeter As Long
bmClrUsed As Long
bmClrImportant As Long
End Type
Private Type BITMAPINFO
bmHeader As BITMAPINFOHEADER
bmColors(0 To 255) As RGBQUAD
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dWidth As Long, ByVal dHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long, ByVal RasterOp As Long) As Long
Private Declare Function GetBitmapDimensionEx Lib "gdi32" (ByVal hBitmap As Long, lpDimension As Size) As Long
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 Size
cx As Long
cy As Long
End Type
Dim bitmapsize As Size
Private Type Color
Red As Long
Green As Long
Blue As Long
End Type
Dim bmLen As Long
Dim bm As BITMAP
Dim bmi As BITMAPINFO
Dim RGBColor As Color
' added this function I use to word align any bitmap bit depth
Private 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
'Rotate an image
Public Sub RotateImage(picSource As Control, picDestiny As Control, ByVal Angle As Single, Optional ByVal PosX As Long = 0, Optional ByVal PosY As Long = 0)
Dim X1 As Long, Y1 As Long
Dim X2 As Long, Y2 As Long
Dim X As Long, Y As Long
Dim CosA As Single, SinA As Single
Dim SrcOffX As Long, SrcOffY As Long
Dim ImageData() As Byte
Dim ImageDataRotated() As Byte
'calculate negative angle in radians, negative because mapping from destination to source
Angle = Angle * 1.74532925199433E-02 'same as Angle * (pi/180) * -1
CosA = Cos(Angle)
SinA = Sin(Angle)
Set picDestiny.Picture = Nothing
'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 picSource.Image, bmLen, bm
'Build a correctly sized array.
ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)
ReDim ImageDataRotated(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
SrcOffX = (bm.bmWidth \ 2)
SrcOffY = (bm.bmHeight \ 2)
'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 picSource.hdc, picSource.Image, 0, bm.bmHeight, ImageData(0, 0), bmi, 0
For Y2 = 0 To bm.bmHeight - 1
For X2 = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
X = X2 - SrcOffX
Y = Y2 - SrcOffY
X1 = (X * CosA - Y * SinA) + SrcOffX
If (X1 >= 0 And X1 < bm.bmWidth) Then
Y1 = (X * SinA + Y * CosA) + SrcOffY
If (Y1 >= 0 And Y1 < bm.bmHeight) Then
ImageDataRotated(X2 + 2, Y2) = ImageData(X1 + 2, Y1) ' Red
ImageDataRotated(X2 + 1, Y2) = ImageData(X1 + 1, Y1) 'Green
ImageDataRotated(X2, Y2) = ImageData(X1, Y1) 'Blue
End If
End If
Next X2
Next Y2
'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 picDestiny.hdc, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageDataRotated(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 picDestiny.AutoRedraw = True Then
picDestiny.Picture = picDestiny.Image
picDestiny.Refresh
End If
End Sub
but i don't get the right results:(
can anyone help me?
thanks
Re: [VB6] DIBs Rotate Image
Re: [VB6] DIBs Rotate Image
Quote:
Originally Posted by
Mikle
works fine;)
i will try change for build a nice procedure;)
but i need hask you 1 thing: can i do it without the mask picture?
(i know, without that, i can see an "hidden" color, but i can take it off;))
thanks
Re: [VB6] DIBs Rotate Image
Re: [VB6] DIBs Rotate Image
Quote:
Originally Posted by
Mikle
i need ask you something: what it's Timer?(i can't find these variable:()
you code can be easy to understand, but i have some problems to understand everything, but i'm trying ctach the idea;)
thanks
Re: [VB6] DIBs Rotate Image
sorry ask you these:(
but can you give me the project more simplificated?
like:
-put 2 pictureboxes in form and 1 textbox for the angle;
-put the image(picturebox1) in variabel array(getdibits());
-then put the result in picturebox2(SetDIBitsToDevice).
sorry ask you these, but i have some problems for finish what i need:(
thanks for everything
Re: [VB6] DIBs Rotate Image
Re: [VB6] DIBs Rotate Image
Quote:
Originally Posted by
Mikle
yes;)
thank you very much
thanks
Re: [RESOLVED] [VB6] DIBs Rotate Image
Hello MIkle,
Thanks for you wonderfull code. It works very well and fast.
I want to save the result to an image file or transfere it to another picturebox or image-controll.
The picture property seems to stay empty also working with the .image property is giving me a empty white .bmp.
Can you please give me an example on how to do that?
Thank you in advance.
Regards,
Bram
Re: [RESOLVED] [VB6] DIBs Rotate Image
Bramazzotti
Change picOut.AutoRedraw property to True, add "Refresh" here:
Code:
Private Sub txt_Change()
Rot Val(txt.Text) * 3.141593 / 180
SetDIBitsToDevice picOut.hDC, 0, 0, Rad2, Rad2, 0, 0, 0, Rad2, ArOut(0, 0), bi32BitInfo, 0
picOut.Refresh
End Sub
Saving to file:
Code:
Private Sub Command1_Click()
SavePicture picOut.Image, "out.bmp"
End Sub
Re: [RESOLVED] [VB6] DIBs Rotate Image
The autoredraw=true in combination with the picout.image (not picture) did the trick.
Thanks!
Re: [RESOLVED] [VB6] DIBs Rotate Image
Mikle,
Hope you can help me again.
Your function works fine but generates bigger pictures as the original. Which is a side effect of rotating images.
I only need to rotate the image with -90 (or 270).
I have an image of 80x160 pixels which needs to be rotated, afther this it should be an image of 160x80 pixels. I have been playing with the pHeight and rad2 variables but do not seem to get it to work.
Can you please help me on this?
Thanks in advance!
Re: [RESOLVED] [VB6] DIBs Rotate Image
Redim your ArOut() array manually. Rotate:
Code:
Public Sub Rotate90(ArIn() As Long, ArOut() As Long)
Dim w As Long, h As Long
Dim x As Long, y As Long
w = UBound(ArIn(), 1) + 1
h = UBound(ArIn(), 2) + 1
For y = 0 To h - 1
For x = 0 To w - 1
ArOut(h - y - 1, x) = ArIn(x, y)
Next x
Next y
End Sub
Public Sub Rotate180(ArIn() As Long, ArOut() As Long)
Dim w As Long, h As Long
Dim x As Long, y As Long
w = UBound(ArIn(), 1) + 1
h = UBound(ArIn(), 2) + 1
For y = 0 To h - 1
For x = 0 To w - 1
ArOut(w - x - 1, h - y - 1) = ArIn(x, y)
Next x
Next y
End Sub
Public Sub Rotate270(ArIn() As Long, ArOut() As Long)
Dim w As Long, h As Long
Dim x As Long, y As Long
w = UBound(ArIn(), 1) + 1
h = UBound(ArIn(), 2) + 1
For y = 0 To h - 1
For x = 0 To w - 1
ArOut(y, w - x - 1) = ArIn(x, y)
Next x
Next y
End Sub
Re: [RESOLVED] [VB6] DIBs Rotate Image
Thank you!
That did the trick!