home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / PolyCube_C2153625292009.psc / bmp_rotate.bas < prev    next >
BASIC Source File  |  2009-05-26  |  3KB  |  78 lines
  1. Attribute VB_Name = "mod_Rotate"
  2. Const Pi = 3.14159265358979
  3. Public Const Trans = Pi / 180
  4. Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  5. Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
  6.  
  7. Public Sub bmp_rotate2(pic1 As PictureBox, pic2 As PictureBox, ByVal theta As Double)
  8.  
  9.     Dim c1x As Double, c1y As Double
  10.     Dim c2x As Double, c2y As Double
  11.     Dim a As Double
  12.     Dim p1x As Double, p1y As Double
  13.     Dim p2x As Double, p2y As Double
  14.     Dim n As Integer, R As Double
  15.     Dim c0 As Long, c1 As Long, c2 As Long, c3 As Long
  16.     
  17.     c1x = pic1.ScaleWidth \ 2 + 40
  18.     c1y = pic1.ScaleHeight \ 2 + 40
  19.     c2x = pic2.ScaleWidth \ 2
  20.     c2y = pic2.ScaleHeight \ 2
  21.     If c2x < c2y Then n = c2y Else n = c2x
  22.     n = (n - 1)
  23.    
  24.     For p2x = 0 To n
  25.         For p2y = 0 To n
  26.             If p2x = 0 Then a = Pi / 2 Else a = Atn(p2y / p2x)
  27.             R = Sqr(1& * p2x * p2x + 1& * p2y * p2y)
  28.             p1x = R * Cos(a + theta)
  29.             p1y = R * Sin(a + theta)
  30.             c0& = pPoint(c1x + p1x, c1y + p1y, pic1.hdc)
  31.             c1& = pPoint(c1x - p1x, c1y - p1y, pic1.hdc)
  32.             c2& = pPoint(c1x + p1y, c1y - p1x, pic1.hdc)
  33.             c3& = pPoint(c1x - p1y, c1y + p1x, pic1.hdc)
  34.             If c0& <> -1 Then SetPixel pic2.hdc, c2x + p2x, c2y + p2y, c0&
  35.             If c1& <> -1 Then SetPixel pic2.hdc, c2x - p2x, c2y - p2y, c1&
  36.             If c2& <> -1 Then SetPixel pic2.hdc, c2x + p2y, c2y - p2x, c2&
  37.             If c3& <> -1 Then SetPixel pic2.hdc, c2x - p2y, c2y + p2x, c3&
  38.         Next
  39.     Next
  40. End Sub
  41.  
  42. 'Use this function to interpolate between up to 4 pixels
  43. Function pPoint(ByVal x As Double, ByVal y As Double, ByVal obj As Long) As Long
  44.     z = Int(x)
  45.     z2 = Int(x + 0.999)
  46.     d2 = x - z
  47.     If (z - z2) = 0 Then 'X integer
  48.         pPoint = pPoint2(z, y, obj)
  49.     Else
  50.         pPoint = RGBDiv(pPoint2(z, y, obj), d2, pPoint2(z2, y, obj), (1 - d2))
  51.     End If
  52. End Function
  53.  
  54. Function pPoint2(ByVal x As Double, ByVal y As Double, ByVal obj As Long) As Long
  55.     z = Int(y)
  56.     z2 = Int(y + 0.999)
  57.     d2 = y - z
  58.     If (z - z2) = 0 Then 'Y integer
  59.         pPoint2 = GetPixel(obj, x, z)
  60.     Else
  61.         pPoint2 = RGBDiv(GetPixel(obj, x, z), d2, GetPixel(obj, x, z2), (1 - d2))
  62.     End If
  63. End Function
  64.  
  65. Function RGBDiv(ByVal c1 As Long, ByVal p2 As Double, ByVal c2 As Long, ByVal p1 As Double)
  66.     r1 = c1 And 255
  67.     g1 = (c1 And (256 ^ 2 - 256)) / 256
  68.     b1 = (c1 And (256 ^ 3 - 65536)) / (256 ^ 2)
  69.     r2 = c2 And 255
  70.     
  71.     g2 = (c2 And (256 ^ 2 - 256)) / 256
  72.     b2 = (c2 And (256 ^ 3 - 65536)) / (256 ^ 2)
  73.     R3 = r1 * p1 + r2 * p2
  74.     G3 = g1 * p1 + g2 * p2
  75.     B3 = b1 * p1 + b2 * p2
  76.     RGBDiv = RGB(R3, G3, B3)
  77. End Function
  78.