Keskustelu: Ohjelmointikysymykset: VB.NET: Kuvan pyöritys & SetDIBits

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 Sub

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 Sub