-
Nov 22nd, 2009, 10:20 AM
#1
Thread Starter
PowerPoster
[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
-
Nov 23rd, 2009, 03:39 AM
#2
Re: [VB6] DIBs Rotate Image
-
Nov 23rd, 2009, 02:05 PM
#3
Thread Starter
PowerPoster
Re: [VB6] DIBs Rotate Image
Last edited by joaquim; Nov 23rd, 2009 at 02:10 PM.
-
Nov 24th, 2009, 07:34 AM
#4
Re: [VB6] DIBs Rotate Image
-
Nov 24th, 2009, 02:22 PM
#5
Thread Starter
PowerPoster
Re: [VB6] DIBs Rotate Image
Last edited by joaquim; Nov 24th, 2009 at 02:31 PM.
-
Nov 24th, 2009, 02:44 PM
#6
Thread Starter
PowerPoster
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
-
Nov 25th, 2009, 03:43 AM
#7
Re: [VB6] DIBs Rotate Image
-
Nov 25th, 2009, 02:48 PM
#8
Thread Starter
PowerPoster
Re: [VB6] DIBs Rotate Image
Originally Posted by Mikle
yes
thank you very much
thanks
-
Feb 21st, 2012, 10:22 AM
#9
New Member
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
-
Feb 22nd, 2012, 12:54 AM
#10
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
-
Feb 22nd, 2012, 04:31 AM
#11
New Member
Re: [RESOLVED] [VB6] DIBs Rotate Image
The autoredraw=true in combination with the picout.image (not picture) did the trick.
Thanks!
-
Feb 22nd, 2012, 07:44 AM
#12
New Member
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!
-
Feb 23rd, 2012, 10:05 AM
#13
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
-
Feb 24th, 2012, 07:35 AM
#14
New Member
Re: [RESOLVED] [VB6] DIBs Rotate Image
Thank you!
That did the trick!
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|