home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / FAST_Magic21308710162008.psc / FastGFX.bas < prev    next >
BASIC Source File  |  2008-09-06  |  6KB  |  186 lines
  1. Attribute VB_Name = "FastGFX"
  2. Option Explicit
  3.  
  4. Public Declare Function FloodFill Lib "gdi32" (ByVal HDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  5.  
  6. Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC 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
  7. Private Declare Function SetDIBits 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
  8.  
  9. Public Type RGBQUAD
  10.  rgbBlue As Byte
  11.  rgbGreen As Byte
  12.  rgbRed As Byte
  13.  rgbReserved As Byte
  14. End Type
  15.  
  16.  
  17. Private Type BITMAPINFOHEADER
  18.  biSize           As Long
  19.  biWidth          As Long
  20.  biHeight         As Long
  21.  biPlanes         As Integer
  22.  biBitCount       As Integer
  23.  biCompression    As Long
  24.  biSizeImage      As Long
  25.  biXPelsPerMeter  As Long
  26.  biYPelsPerMeter  As Long
  27.  biClrUsed        As Long
  28.  biClrImportant   As Long
  29. End Type
  30.  
  31. Private Type BITMAPINFO
  32.  bmiHeader As BITMAPINFOHEADER
  33. End Type
  34.  
  35. Private Const DIB_RGB_COLORS As Long = 0
  36.  
  37. Public Buf1() As RGBQUAD
  38. Public Buf2() As RGBQUAD
  39.  
  40.  
  41. 'Convert Picture to Array
  42. Public Sub Pic2Array(PicBox As PictureBox, ByRef PicArray() As RGBQUAD)
  43.  
  44.  Dim Binfo       As BITMAPINFO   'The GetDIBits API needs some Infos
  45.  ReDim PicArray(0 To PicBox.ScaleWidth - 1, 0 To PicBox.ScaleHeight - 1)
  46.  
  47. With Binfo.bmiHeader
  48.  .biSize = 40
  49.  .biWidth = PicBox.ScaleWidth
  50.  .biHeight = PicBox.ScaleHeight
  51.  .biPlanes = 1
  52.  .biBitCount = 32
  53.  .biCompression = 0
  54.  .biClrUsed = 0
  55.  .biClrImportant = 0
  56.  .biSizeImage = PicBox.ScaleWidth * PicBox.ScaleHeight
  57. End With
  58. 'Now get the Picture
  59. GetDIBits PicBox.HDC, PicBox.Image.handle, 0, Binfo.bmiHeader.biHeight, PicArray(0, 0), Binfo, DIB_RGB_COLORS
  60.  
  61. End Sub
  62. 'Convert Array to Picture
  63. Public Sub Array2Pic(PicBox As PictureBox, ByRef PicArray() As RGBQUAD)
  64.  
  65.  Dim Binfo       As BITMAPINFO   'The GetDIBits API needs some Infos
  66.  
  67. With Binfo.bmiHeader
  68.  .biSize = 40
  69.  .biWidth = PicBox.ScaleWidth
  70.  .biHeight = PicBox.ScaleHeight
  71.  .biPlanes = 1
  72.  .biBitCount = 32
  73.  .biCompression = 0
  74.  .biClrUsed = 0
  75.  .biClrImportant = 0
  76.  .biSizeImage = PicBox.ScaleWidth * PicBox.ScaleHeight
  77. End With
  78. SetDIBits PicBox.HDC, PicBox.Image.handle, 0, Binfo.bmiHeader.biHeight, PicArray(0, 0), Binfo, DIB_RGB_COLORS
  79.  
  80. End Sub
  81. 'Monochrome a Picture
  82. Public Sub PicMonochrome(PicAr() As RGBQUAD)
  83.  Dim X As Long
  84.  Dim Y As Long
  85.  Dim col As Long
  86.  
  87.  For X = 0 To UBound(PicAr, 1)
  88.   For Y = 0 To UBound(PicAr, 2)
  89.    'calculate the Colors
  90.    'Red * 0,3 + Green * 0,59 + Blue * 0,11 gives us the Graycolor
  91.    'The Maximum result is 255
  92.    col = 0.3 * CLng(PicAr(X, Y).rgbRed) + 0.59 * CLng(PicAr(X, Y).rgbGreen) + 0.11 * CLng(PicAr(X, Y).rgbBlue)
  93.    'For this we only need the red channel
  94.    PicAr(X, Y).rgbRed = col
  95.    'PicAr(x, y).rgbGreen = col
  96.    'PicAr(x, y).rgbBlue = col
  97.   Next Y
  98.  Next X
  99. End Sub
  100. 'Hue a Picture
  101. 'Not my code
  102. 'found it somewhere in the www
  103. 'needs to be optimized
  104. Public Sub PicHue(PicAr() As RGBQUAD)
  105.  Dim X As Long
  106.  Dim Y As Long
  107.  Dim R As Integer, G As Integer, B As Integer
  108.  Dim cMax As Integer, cMin As Integer
  109.  Dim RDelta As Double, GDelta As Double, BDelta As Double
  110.  Dim H As Single
  111.  Dim s As Single
  112.  Dim l As Single
  113.  Dim cMinus As Long, cPlus As Long
  114.  Dim notthere As Boolean
  115.  
  116.  For X = 0 To UBound(PicAr, 1)
  117.   For Y = 0 To UBound(PicAr, 2)
  118.    R = PicAr(X, Y).rgbRed
  119.    G = PicAr(X, Y).rgbGreen
  120.    B = PicAr(X, Y).rgbBlue
  121.    
  122.    'Calculate the hue
  123.    cMax = Maximum(R, G, B) 'iMax(iMax(R, G), B) 'Highest and lowest
  124.    cMin = Minimum(R, G, B) 'iMin(iMin(R, G), B) 'color values
  125.  
  126.    cMinus = cMax - cMin 'Used to simplify the
  127.    cPlus = cMax + cMin  'calculations somewhat.
  128.    If cMax = cMin Then 'achromatic (r=g=b, greyscale)
  129.     H = 160
  130.    Else
  131.     RDelta = ((cMax - R) * 40 + 0.5) / cMinus
  132.     GDelta = ((cMax - G) * 40 + 0.5) / cMinus
  133.     BDelta = ((cMax - B) * 40 + 0.5) / cMinus
  134.  
  135.  If cMax = CLng(R) Then
  136.      H = BDelta - GDelta
  137.  ElseIf cMax = CLng(G) Then
  138.      H = 80 + RDelta - BDelta
  139.  Else
  140.      H = 160 + GDelta - RDelta
  141.  End If
  142.  
  143.  
  144.     If H < 0 Then H = H + 240
  145.    End If
  146.  
  147.    'For this we only need the red channel
  148.    PicAr(X, Y).rgbRed = H
  149.    'PicAr(x, y).rgbGreen = H
  150.    'PicAr(x, y).rgbBlue = H
  151.   Next Y
  152.  Next X
  153.  
  154. End Sub
  155. Public Function Maximum(rR As Integer, rG As Integer, rB As Integer) As Integer
  156.     If (rR > rG) Then
  157.         If (rR > rB) Then Maximum = rR Else Maximum = rB
  158.       Else
  159.         If (rB > rG) Then Maximum = rB Else Maximum = rG
  160.     End If
  161. End Function
  162.  
  163. Public Function Minimum(rR As Integer, rG As Integer, rB As Integer) As Integer
  164.     If (rR < rG) Then
  165.         If (rR < rB) Then Minimum = rR Else Minimum = rB
  166.       Else
  167.         If (rB < rG) Then Minimum = rB Else Minimum = rG
  168.     End If
  169. End Function
  170.  
  171. 'Check if a Color is ind a range X% from the actual point
  172. Public Function SimilarColor(ByVal Red1 As Long, ByVal Green1 As Long, ByVal Blue1 As Long, ByVal Red2 As Long, ByVal Green2 As Long, ByVal Blue2 As Long, ByVal Percent As Long) As Boolean
  173.  'We have 255 Colors so wen need 100*2.55 to get all
  174.  Percent = Percent * 2.55
  175.  'Check if the color is in our range
  176.  If Abs(Red1 - Red2) <= Percent And Abs(Green1 - Green2) <= Percent And Abs(Blue1 - Blue2) <= Percent Then SimilarColor = True
  177. End Function
  178.  
  179. Public Function SameColor(Red As Byte, Blue As Byte, Green As Byte) As Byte
  180. Dim Tmp As Byte
  181. If Red > Green Then Tmp = 1
  182. If Green > Blue Then Tmp = Tmp + 10
  183. If Red > Blue Then Tmp = Tmp + 100
  184. SameColor = Tmp
  185. End Function
  186.