home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH4 / SRC / UNSHARP.CLS < prev    next >
Encoding:
Text File  |  1997-01-03  |  3.9 KB  |  146 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "Filter"
  6. Attribute VB_Creatable = False
  7. Attribute VB_Exposed = False
  8. Option Explicit
  9.  
  10. Private Bound As Integer
  11. Private Kernel() As Single
  12. Private Wgt As Single
  13.  
  14. ' ************************************************
  15. ' Apply the filter to an array of bits.
  16. ' ************************************************
  17. Public Sub ApplyFilter(from_pict As Object, to_pict As Object, show_progress As Boolean)
  18. Dim bm As BITMAP
  19. Dim hbm As Integer
  20. Dim status As Long
  21. Dim bytesin() As Byte
  22. Dim bytesout() As Byte
  23. Dim wid As Long
  24. Dim hgt As Long
  25. Dim i As Integer
  26. Dim j As Integer
  27.  
  28. Dim hPal As Integer
  29. Dim palentry(0 To 255) As PALETTEENTRY
  30. Dim X As Integer
  31. Dim Y As Integer
  32. Dim r As Long
  33. Dim g As Long
  34. Dim b As Long
  35.  
  36.     ' *****************************
  37.     ' * Get the input bitmap data *
  38.     ' *****************************
  39.     ' Get a handle to the input bitmap.
  40.     hbm = from_pict.Image
  41.     
  42.     ' See how big it is.
  43.     status = GetObject(hbm, BITMAP_SIZE, bm)
  44.     wid = bm.bmWidthBytes
  45.     hgt = bm.bmHeight
  46.     
  47.     ' Get the bits.
  48.     ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
  49.     status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
  50.     ReDim bytesout(0 To wid - 1, 0 To hgt - 1)
  51.     
  52.     ' ********************
  53.     ' * Apply the filter *
  54.     ' ********************
  55.     ' Get the current color values.
  56.     hPal = from_pict.Picture.hPal
  57.     i = GetPaletteEntries(hPal, 0, 255, palentry(0))
  58.  
  59.     ' Compute the new color values.
  60.     For X = Bound To wid - 1 - Bound
  61.         ' If the operation has been canceled, stop.
  62.         DoEvents
  63.         If Not OperationRunning Then Exit For
  64.         
  65.         ' If we should show progress, do so.
  66.         If show_progress Then
  67.             status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
  68.             to_pict.Refresh
  69.         End If
  70.         
  71.         For Y = Bound To hgt - 1 - Bound
  72.             r = 0
  73.             g = 0
  74.             b = 0
  75.             For i = -Bound To Bound
  76.                 For j = -Bound To Bound
  77.                     With palentry(bytesin(X + i, Y + j))
  78.                         r = r + Kernel(i, j) * .peRed
  79.                         g = g + Kernel(i, j) * .peGreen
  80.                         b = b + Kernel(i, j) * .peBlue
  81.                     End With
  82.                 Next j
  83.             Next i
  84.             r = r / Wgt
  85.             g = g / Wgt
  86.             b = b / Wgt
  87.             If r < 0 Then r = 0
  88.             If g < 0 Then g = 0
  89.             If b < 0 Then b = 0
  90.             bytesout(X, Y) = GetNearestPaletteIndex( _
  91.                 hPal, RGB(r, g, b) + &H2000000)
  92.         Next Y
  93.     Next X
  94.     
  95.     ' **********************
  96.     ' * Display the output *
  97.     ' **********************
  98.     status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
  99.     to_pict.Refresh
  100. End Sub
  101.  
  102.  
  103.  
  104.  
  105. ' ************************************************
  106. ' Initialize a high pass (sharpening) filter.
  107. ' ************************************************
  108. Public Sub InitializeHighPass(size As Integer)
  109. Dim r As Integer
  110. Dim c As Integer
  111. Dim vr As Integer
  112.  
  113.     Bound = size \ 2
  114.     ReDim Kernel(-Bound To Bound, -Bound To Bound)
  115.     
  116.     For r = -Bound To Bound
  117.         vr = Bound + 1 - Abs(r)
  118.         For c = -Bound To Bound
  119.             Kernel(r, c) = vr * (Bound + 1 - Abs(c))
  120.             Wgt = Wgt + Kernel(r, c)
  121.         Next c
  122.     Next r
  123. End Sub
  124.  
  125. ' ************************************************
  126. ' Initialize a low pass (blurring) filter.
  127. ' ************************************************
  128. Public Sub InitializeLowPass(size As Integer)
  129. Dim r As Integer
  130. Dim c As Integer
  131. Dim vr As Integer
  132.  
  133.     Bound = size \ 2
  134.     ReDim Kernel(-Bound To Bound, -Bound To Bound)
  135.     
  136.     For r = -Bound To Bound
  137.         vr = Bound + 1 - Abs(r)
  138.         For c = -Bound To Bound
  139.             Kernel(r, c) = vr * (Bound + 1 - Abs(c))
  140.             Wgt = Wgt + Kernel(r, c)
  141.         Next c
  142.     Next r
  143. End Sub
  144.  
  145.  
  146.