Koodi on muuten hyvä, mutta se sotkee kuvan ulkopuolelle mustaa väriä koko contextin täydeltä. Millä siitä pääsisi eroon ? Netistä löytyi myös koodi, joka piirsi contextille pelkän kuvan (kuten pitääkin). Tämä koodi sattui vaan olevaan kelvoton monella muulla tapaa, mm. koska pyöritetty kuva menee reunojen yli jne jne. Voiko hyvät ominaisuudet näistä kahdesta ynnätä ja saada hyvän koodin ? miten ?
musta lammas:
Public Sub BitRotate(srcDC As Long, srcHandle As StdPicture, destDC As Long, destHandle As StdPicture, ByVal Angle As Double, ByVal AntiAlias As Boolean)
'Store a few attributes of the pictures for increased speed
Dim tempBIH As BITMAPINFOHEADER
Dim TempAlpha As Byte
Dim biSize As Long
biSize = LenB(tempBIH)
Dim Info As BITMAPINFO
Dim Info2 As BITMAPINFO
Info.Header.biSize = biSize
Info2.Header.biSize = biSize
GetDIBits srcDC, srcHandle, 0, 0, 0&, Info, 0
GetDIBits destDC, destHandle, 0, 0, 0&, Info2, 0
SourceWidth = Info.Header.biWidth
SourceHeight = Info.Header.biHeight
DestWidth = Info2.Header.biWidth
DestHeight = Info2.Header.biHeight
Dim NewSize As Long
NewSize = Sqr(DestWidth * DestWidth + DestHeight * DestHeight) + 2
'Allocate array for source picture's bits
ReDim SourceBuffer.Bits(3, SourceWidth - 1, SourceHeight - 1)
With SourceBuffer.Header
.biSize = 40
.biWidth = SourceWidth
.biHeight = -SourceHeight
.biPlanes = 1
.biBitCount = 32
.biSizeImage = 3 * SourceWidth * SourceHeight
End With
'Get source pictures bits
GetDIBits srcDC, srcHandle, 0, SourceHeight, SourceBuffer.Bits(0, 0, 0), SourceBuffer, 0&
'Allocate array for dest picture's bits
ReDim DestBuffer.Bits(3, DestWidth - 1, DestHeight - 1)
With DestBuffer.Header
.biSize = 40
.biWidth = DestWidth
.biHeight = -DestHeight
.biPlanes = 1
.biBitCount = 32
.biSizeImage = 3 * DestWidth * DestHeight
End With
'Get center of source picture
cx = SourceWidth * 0.5
cy = SourceHeight * 0.5
'Get center of destination picture
dx = DestWidth * 0.5
dy = DestHeight * 0.5
'Convert angle to Sin/Cos radians
cosa = Cos(Angle * Deg2Rad * -1)
sina = Sin(Angle * Deg2Rad * -1)
'Get bounds of source picture
biW = SourceWidth - 1
biH = SourceHeight - 1
SetRect biRct, 0, 0, biW, biH
'Clear dectination picture
Rotate.picDestination.Cls
For y = 0 To DestHeight - 1
'Destination Y to calculate
yin = y - dy
For x = 0 To DestWidth - 1
'Destination X to calculate
xin = x - dx
'Rotate destination X, Y according to angle in radians
rx = xin * cosa - yin * sina + cx
ry = xin * sina + yin * cosa + cy
'Round of rotated pixels X, Y coordinates
irx = Int(rx)
iry = Int(ry)
'If rotated pixel is within bounds of destination
If (PtInRect(biRct, irx, iry)) Then
'Convert pixel to destination
drx = rx - irx
dry = ry - iry
'If Anti-Alias switch is on
If AntiAlias Then
'Get rotated pixel
r1 = SourceBuffer.Bits(2, irx, iry)
g1 = SourceBuffer.Bits(1, irx, iry)
b1 = SourceBuffer.Bits(0, irx, iry)
'Get rotated pixels right neighbor
r2 = SourceBuffer.Bits(2, irx + 1, iry)
g2 = SourceBuffer.Bits(1, irx + 1, iry)
b2 = SourceBuffer.Bits(0, irx + 1, iry)
'Get rotated pixels lower neighbor
r3 = SourceBuffer.Bits(2, irx, iry + 1)
g3 = SourceBuffer.Bits(1, irx, iry + 1)
b3 = SourceBuffer.Bits(0, irx, iry + 1)
'Get rotated pixels lower right neighbor
r4 = SourceBuffer.Bits(2, irx + 1, iry + 1)
g4 = SourceBuffer.Bits(1, irx + 1, iry + 1)
b4 = SourceBuffer.Bits(0, irx + 1, iry + 1)
'Interpolate pixels along Y axis
ib1 = b1 * (1 - dry) + b3 * dry
ig1 = g1 * (1 - dry) + g3 * dry
ir1 = r1 * (1 - dry) + r3 * dry
ib2 = b2 * (1 - dry) + b4 * dry
ig2 = g2 * (1 - dry) + g4 * dry
ir2 = r2 * (1 - dry) + r4 * dry
'Interpolate pixels along X axis
b = ib1 * (1 - drx) + ib2 * drx
G = ig1 * (1 - drx) + ig2 * drx
R = ir1 * (1 - drx) + ir2 * drx
'Check for valid color range
If (R < 0) Then R = 0 Else If (R > 255) Then R = 255
If (G < 0) Then G = 0 Else If (G > 255) Then G = 255
If (b < 0) Then b = 0 Else If (b > 255) Then b = 255
'Plot interpolated pixel to destination picture
DestBuffer.Bits(2, x, y) = R
DestBuffer.Bits(1, x, y) = G
DestBuffer.Bits(0, x, y) = b
Else
'Get rotated pixel
R = SourceBuffer.Bits(2, irx, iry)
G = SourceBuffer.Bits(1, irx, iry)
b = SourceBuffer.Bits(0, irx, iry)
'Plot rotated pixel to destination picture
DestBuffer.Bits(2, x, y) = R
DestBuffer.Bits(1, x, y) = G
DestBuffer.Bits(0, x, y) = b
End If
End If
Next x
Next y
'Load destination bits to destination picture
SetDIBits destDC, destHandle, 0, DestHeight, DestBuffer.Bits(0, 0, 0), DestBuffer, 0&
End Subtoisenlainen ratkaisu:
Public Sub RotateDC(DstDC As Long, DstX As Long, DstY As Long, SrcDC As Long, SrcBmp As Long, Deg As Long)
Dim TmpDC As Long
Dim TmpBmp As Long
Dim OldObject As Long
Dim BitCount As Long
Dim LineWidth As Long
Dim retVal As Long
Dim Width As Long
Dim Height As Long
Dim h&, b&, f&, d&, i&
Dim dx1 As Double
dx1 = 1#
Dim dy1 As Double
Dim SrcBits() As Byte
Dim TmpBits() As Byte
Dim tempBIH As BITMAPINFOHEADER
Dim TempAlpha As Byte
Dim biSize As Long
biSize = LenB(tempBIH)
Dim Info As BITMAPINFO
Dim Info2 As BITMAPINFO
Info.bmiHeader.biSize = biSize
Info2.bmiHeader.biSize = biSize
retVal = GetDIBits(SrcDC, SrcBmp, 0, 0, 0&, Info, DIB_RGB_COLORS)
If retVal = 0 And Info.bmiHeader.biWidth = 0 Then Exit Sub
TmpDC = CreateCompatibleDC(SrcDC)
Width = Info.bmiHeader.biWidth
Height = Info.bmiHeader.biHeight
Dim NewSize As Long
NewSize = Sqr(Width * Width + Height * Height) + 2
TmpBmp = CreateCompatibleBitmap(SrcDC, NewSize, NewSize)
If (TmpBmp <> 0) Then
OldObject = SelectObject(TmpDC, TmpBmp)
BitBlt TmpDC, 0, 0, NewSize, NewSize, DstDC, DstX - NewSize / 2, DstY - NewSize / 2, vbSrcCopy
Info.bmiHeader.biBitCount = 24
Info.bmiHeader.biCompression = 0
Info2.bmiHeader.biBitCount = 24
Info2.bmiHeader.biCompression = 0
Info2.bmiHeader.biPlanes = 1
Info2.bmiHeader.biHeight = NewSize
Info2.bmiHeader.biWidth = NewSize
Dim LineWidth2
LineWidth2 = NewSize * 3
If (LineWidth2 Mod 4 <> 0) Then LineWidth2 = LineWidth2 + (4 - LineWidth2 Mod 4)
Dim BitCount2 As Long
BitCount2 = LineWidth2 * NewSize
LineWidth = Width * 3
If (LineWidth Mod 4 <> 0) Then LineWidth = LineWidth + (4 - LineWidth Mod 4)
BitCount = LineWidth * Height
ReDim SrcBits(0 To BitCount - 1) As Byte
ReDim TmpBits(0 To BitCount2 - 1) As Byte
GetDIBits SrcDC, SrcBmp, 0, Height, SrcBits(0), Info, DIB_RGB_COLORS
GetDIBits TmpDC, TmpBmp, 0, NewSize, TmpBits(0), Info2, DIB_RGB_COLORS
Dim CurOffset As Long
Dim NewX As Double, NewY As Double
Dim Xmm As Long, Ymm As Long
Dim i1 As Long
Dim v1 As Boolean
dx1 = Cos(Deg * PIDEG)
dy1 = Sin(Deg * PIDEG)
For h = 0 To NewSize - 1
CurOffset = LineWidth2 * h
For b = 0 To NewSize - 1
f = CurOffset + 3 * b
NewX = Width / 2 + (b - NewSize / 2) * dx1 - (h - NewSize / 2) * dy1
NewY = Height / 2 + (b - NewSize / 2) * dy1 + (h - NewSize / 2) * dx1
Xmm = (NewX + 0.5)
Ymm = (NewY + 0.5)
If ((Xmm >= 0) And (Xmm < Width) And (Ymm >= 0) And (Ymm < Height)) Then
v1 = True
i1 = LineWidth * Ymm + 3 * Xmm
If v1 Then
For d = 0 To 2
TmpBits(f + d) = SrcBits(i1 + d)
Next d
End If
End If
Next b
Next h
SetDIBitsToDevice DstDC, DstX - NewSize / 2, DstY - NewSize / 2, NewSize, NewSize, 0, 0, 0, NewSize, TmpBits(0), Info2, DIB_RGB_COLORS
DeleteObject SelectObject(TmpDC, OldObject)
End If
DeleteDC TmpDC
End SubOnko kyseessä VB.NET?
Olisiko tästä apua?
Aihe on jo aika vanha, joten et voi enää vastata siihen.