home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / iICO_1_01816331192004.psc / cDIBDither.cls < prev    next >
Text File  |  2004-06-15  |  17KB  |  414 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cDIBDither"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. '================================================
  17. ' Class:         cDIBDither.cls
  18. ' Author:        Carles P.V.
  19. ' Dependencies:  cDIB.cls
  20. '                cPalette.cls
  21. ' Last revision: -
  22. '================================================
  23.  
  24. Option Explicit
  25.  
  26. '-- API:
  27.  
  28. Private Type SAFEARRAYBOUND
  29.     cElements As Long
  30.     lLbound   As Long
  31. End Type
  32.  
  33. Private Type SAFEARRAY2D
  34.     cDims      As Integer
  35.     fFeatures  As Integer
  36.     cbElements As Long
  37.     cLocks     As Long
  38.     pvData     As Long
  39.     Bounds(1)  As SAFEARRAYBOUND
  40. End Type
  41.  
  42. Private Declare Function VarPtrArray Lib "msvbvm50" Alias "VarPtr" (Ptr() As Any) As Long
  43. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
  44.  
  45. '//
  46.  
  47. '-- Private Variables:
  48. Private m_Pow2(31)  As Long
  49.  
  50.  
  51.  
  52. '========================================================================================
  53. ' Class
  54. '========================================================================================
  55.  
  56. Private Sub Class_Initialize()
  57.  
  58.   Dim lIdx As Long
  59.  
  60.     For lIdx = 0 To 30
  61.         m_Pow2(lIdx) = 2 ^ lIdx
  62.     Next lIdx
  63.     m_Pow2(31) = &H80000000
  64. End Sub
  65.  
  66. Private Sub Class_Terminate()
  67.     Erase m_Pow2()
  68. End Sub
  69.  
  70. '========================================================================================
  71. ' Methods
  72. '========================================================================================
  73.  
  74. Public Sub DitherToGreyScale(oDIB32In As cDIB, oDIBOut As cDIB, Optional ByVal Diffuse As Boolean = False)
  75. '-- Floyd-Steinberg error diffusion
  76.  
  77.   Dim aBitsIn()  As Byte
  78.   Dim uSAIn      As SAFEARRAY2D
  79.   Dim aBitsOut() As Byte
  80.   Dim uSAOut     As SAFEARRAY2D
  81.  
  82.   Dim x As Long, xIn As Long
  83.   Dim y As Long, yIn As Long
  84.   Dim W As Long
  85.   Dim H As Long
  86.  
  87.   Dim L As Byte
  88.  
  89.   Dim errR As Long, errG As Long, errB As Long
  90.   Dim newR As Long, newG As Long, newB As Long
  91.  
  92.     If (oDIB32In.BPP = [32_bpp]) Then
  93.  
  94.         Call pvMapDIB(oDIB32In, aBitsIn(), uSAIn)
  95.         Call pvMapDIB(oDIBOut, aBitsOut(), uSAOut)
  96.  
  97.         W = oDIB32In.Width - 1
  98.         H = oDIB32In.Height - 1
  99.  
  100.         For y = 0 To H
  101.             For x = 0 To W
  102.             
  103.                 '-- Get grey level
  104.                 xIn = 4 * x
  105.                 L = (299 * CLng(aBitsIn(xIn + 2, y)) + _
  106.                      587 * CLng(aBitsIn(xIn + 1, y)) + _
  107.                      114 * CLng(aBitsIn(xIn + 0, y)) _
  108.                      ) \ 1000
  109.                 
  110.                 '-- Pre-dither source
  111.                 aBitsIn(xIn + 0, y) = L
  112.                 aBitsIn(xIn + 1, y) = L
  113.                 aBitsIn(xIn + 2, y) = L
  114.                 
  115.                 '-- Set target index/color
  116.                 Select Case oDIBOut.BPP
  117.                 
  118.                     Case [01_bpp]
  119.                         
  120.                         xIn = x \ 8
  121.                         If (L < 128) Then
  122.                             aBitsOut(xIn, y) = aBitsOut(xIn, y) And Not m_Pow2(7 - (x Mod 8))
  123.                             L = 0
  124.                           Else
  125.                             aBitsOut(xIn, y) = aBitsOut(xIn, y) Or m_Pow2(7 - (x Mod 8))
  126.                             L = 255
  127.                         End If
  128.                     
  129.                     Case [04_bpp]
  130.                         
  131.                         xIn = x \ 2
  132.                         If (x Mod 2 = 0) Then
  133.                             aBitsOut(xIn, y) = (aBitsOut(xIn, y) And &HF) Or L * &H10
  134.                           Else
  135.                             aBitsOut(xIn, y) = (aBitsOut(xIn, y) And &HF0) Or L
  136.                         End If
  137.                         L = L * 17
  138.  
  139.                     Case [08_bpp]
  140.                     
  141.                         aBitsOut(x, y) = L
  142.  
  143.                     Case [24_bpp]
  144.                     
  145.                         xIn = 3 * x
  146.                         aBitsOut(xIn + 0, y) = L
  147.                         aBitsOut(xIn + 1, y) = L
  148.                         aBitsOut(xIn + 2, y) = L
  149.  
  150.                     Case [32_bpp]
  151.                     
  152.                         xIn = 4 * x
  153.                         aBitsOut(xIn + 0, y) = L
  154.                         aBitsOut(xIn + 1, y) = L
  155.                         aBitsOut(xIn + 2, y) = L
  156.                 End Select
  157.                         
  158.                 '-- Diffuse error
  159.                 If (Diffuse) Then
  160.                     
  161.                     xIn = 4 * x
  162.                     errB = CLng(aBitsIn(xIn + 0, y)) - L
  163.                     errG = CLng(aBitsIn(xIn + 1, y)) - L
  164.                     errR = CLng(aBitsIn(xIn + 2, y)) - L
  165.                     aBitsIn(xIn + 0, y) = L
  166.                     aBitsIn(xIn + 1, y) = L
  167.                     aBitsIn(xIn + 2, y) = L
  168.  
  169.                     '-- Floyd-Steinberg error diffusion...
  170.                     If (Abs(errB) + Abs(errG) + Abs(errR) > 3) Then
  171.                         If (x < W) Then
  172.                             xIn = 4 * x + 4
  173.                             newB = aBitsIn(xIn + 0, y) + (7 * errB) / 16
  174.                             newG = aBitsIn(xIn + 1, y) + (7 * errG) / 16
  175.                             newR = aBitsIn(xIn + 2, y) + (7 * errR) / 16
  176.                             If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  177.                             If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  178.                             If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  179.                             aBitsIn(xIn + 0, y) = newB
  180.                             aBitsIn(xIn + 1, y) = newG
  181.                             aBitsIn(xIn + 2, y) = newR
  182.                         End If
  183.                         If (y < H) Then
  184.                             xIn = 4 * x
  185.                             yIn = y + 1
  186.                             newB = aBitsIn(xIn + 0, yIn) + (5 * errB) / 16
  187.                             newG = aBitsIn(xIn + 1, yIn) + (5 * errG) / 16
  188.                             newR = aBitsIn(xIn + 2, yIn) + (5 * errR) / 16
  189.                             If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  190.                             If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  191.                             If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  192.                             aBitsIn(xIn + 0, yIn) = newB
  193.                             aBitsIn(xIn + 1, yIn) = newG
  194.                             aBitsIn(xIn + 2, yIn) = newR
  195.                             If (x < W) Then
  196.                                 xIn = 4 * x + 4
  197.                                 newB = aBitsIn(xIn + 0, yIn) + errB / 16
  198.                                 newG = aBitsIn(xIn + 1, yIn) + errG / 16
  199.                                 newR = aBitsIn(xIn + 2, yIn) + errR / 16
  200.                                 If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  201.                                 If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  202.                                 If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  203.                                 aBitsIn(xIn + 0, yIn) = newB
  204.                                 aBitsIn(xIn + 1, yIn) = newG
  205.                                 aBitsIn(xIn + 2, yIn) = newR
  206.                             End If
  207.                             If (x > 0) Then
  208.                                 xIn = 4 * x - 4
  209.                                 newB = aBitsIn(xIn + 0, yIn) + (3 * errB) / 16
  210.                                 newG = aBitsIn(xIn + 1, yIn) + (3 * errG) / 16
  211.                                 newR = aBitsIn(xIn + 2, yIn) + (3 * errR) / 16
  212.                                 If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  213.                                 If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  214.                                 If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  215.                                 aBitsIn(xIn + 0, yIn) = newB
  216.                                 aBitsIn(xIn + 1, yIn) = newG
  217.                                 aBitsIn(xIn + 2, yIn) = newR
  218.                             End If
  219.                         End If
  220.                     End If
  221.                   Else
  222.                     aBitsIn(xIn + 0, y) = L
  223.                     aBitsIn(xIn + 1, y) = L
  224.                     aBitsIn(xIn + 2, y) = L
  225.                 End If
  226.             Next x
  227.         Next y
  228.         Call pvUnmapDIB(aBitsIn())
  229.         Call pvUnmapDIB(aBitsOut())
  230.     End If
  231. End Sub
  232.  
  233. Public Sub DitherToColorPalette(oPalIn As cPalette, oDIB32In As cDIB, oDIBOut As cDIB, Optional ByVal Diffuse As Boolean = False)
  234. '-- Floyd-Steinberg error diffusion
  235.  
  236.   Dim aBitsIn()  As Byte
  237.   Dim uSAIn      As SAFEARRAY2D
  238.   Dim aBitsOut() As Byte
  239.   Dim uSAOut     As SAFEARRAY2D
  240.  
  241.   Dim x As Long, xIn As Long
  242.   Dim y As Long, yIn As Long
  243.   Dim W As Long
  244.   Dim H As Long
  245.  
  246.   Dim aPalette() As Byte
  247.   Dim aEntry     As Byte
  248.   Dim lEntry     As Long
  249.  
  250.   Dim errR As Long, errG As Long, errB As Long
  251.   Dim newR As Long, newG As Long, newB As Long
  252.  
  253.     If (oDIB32In.BPP = [32_bpp]) Then
  254.  
  255.         Call pvMapDIB(oDIB32In, aBitsIn(), uSAIn)
  256.         Call pvMapDIB(oDIBOut, aBitsOut(), uSAOut)
  257.  
  258.         W = oDIB32In.Width - 1
  259.         H = oDIB32In.Height - 1
  260.  
  261.         '-- Speed up for GetNearestPaletteIndex
  262.         ReDim aPalette(4 * oPalIn.Entries - 1)
  263.         Call CopyMemory(aPalette(0), ByVal oPalIn.lpPalette, 4 * oPalIn.Entries)
  264.  
  265.         For y = 0 To H
  266.             For x = 0 To W
  267.  
  268.                 '-- Get palette index
  269.                 xIn = 4 * x
  270.                 Call oPalIn.ClosestIndex(aBitsIn(xIn + 2, y), _
  271.                                          aBitsIn(xIn + 1, y), _
  272.                                          aBitsIn(xIn + 0, y), _
  273.                                          aEntry)
  274.                 lEntry = 4 * aEntry
  275.  
  276.                 '-- Set target index/color
  277.                 Select Case oDIBOut.BPP
  278.                 
  279.                     Case [01_bpp]
  280.                         
  281.                         xIn = x \ 8
  282.                         If (aEntry = 0) Then
  283.                             aBitsOut(xIn, y) = aBitsOut(xIn, y) And Not m_Pow2(7 - (x Mod 8))
  284.                           Else
  285.                             aBitsOut(xIn, y) = aBitsOut(xIn, y) Or m_Pow2(7 - (x Mod 8))
  286.                         End If
  287.                     
  288.                     Case [04_bpp]
  289.                         
  290.                         xIn = x \ 2
  291.                         If (x Mod 2 = 0) Then
  292.                             aBitsOut(xIn, y) = (aBitsOut(xIn, y) And &HF) Or aEntry * &H10
  293.                           Else
  294.                             aBitsOut(xIn, y) = (aBitsOut(xIn, y) And &HF0) Or aEntry
  295.                         End If
  296.                     
  297.                     Case [08_bpp]
  298.                         
  299.                         aBitsOut(x, y) = aEntry
  300.                         
  301.                     Case [24_bpp]
  302.                         
  303.                         xIn = 3 * x
  304.                         aBitsOut(xIn + 0, y) = aPalette(lEntry + 0)
  305.                         aBitsOut(xIn + 1, y) = aPalette(lEntry + 1)
  306.                         aBitsOut(xIn + 2, y) = aPalette(lEntry + 2)
  307.  
  308.                     Case [32_bpp]
  309.                         
  310.                         xIn = 4 * x
  311.                         aBitsOut(xIn + 0, y) = aPalette(lEntry + 0)
  312.                         aBitsOut(xIn + 1, y) = aPalette(lEntry + 1)
  313.                         aBitsOut(xIn + 2, y) = aPalette(lEntry + 2)
  314.                 End Select
  315.  
  316.                 '-- Diffuse error
  317.                 If (Diffuse) Then
  318.                     
  319.                     xIn = 4 * x
  320.                     errB = CLng(aBitsIn(xIn + 0, y)) - aPalette(lEntry + 0)
  321.                     errG = CLng(aBitsIn(xIn + 1, y)) - aPalette(lEntry + 1)
  322.                     errR = CLng(aBitsIn(xIn + 2, y)) - aPalette(lEntry + 2)
  323.                     aBitsIn(xIn + 0, y) = aPalette(lEntry + 0)
  324.                     aBitsIn(xIn + 1, y) = aPalette(lEntry + 1)
  325.                     aBitsIn(xIn + 2, y) = aPalette(lEntry + 2)
  326.  
  327.                     '-- Floyd-Steinberg error diffusion...
  328.                     If (Abs(errB) + Abs(errG) + Abs(errR) > 3) Then
  329.                         If (x < W) Then
  330.                             xIn = 4 * x + 4
  331.                             newB = aBitsIn(xIn + 0, y) + (7 * errB) / 16
  332.                             newG = aBitsIn(xIn + 1, y) + (7 * errG) / 16
  333.                             newR = aBitsIn(xIn + 2, y) + (7 * errR) / 16
  334.                             If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  335.                             If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  336.                             If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  337.                             aBitsIn(xIn + 0, y) = newB
  338.                             aBitsIn(xIn + 1, y) = newG
  339.                             aBitsIn(xIn + 2, y) = newR
  340.                         End If
  341.                         If (y < H) Then
  342.                             xIn = 4 * x
  343.                             yIn = y + 1
  344.                             newB = aBitsIn(xIn + 0, yIn) + (5 * errB) / 16
  345.                             newG = aBitsIn(xIn + 1, yIn) + (5 * errG) / 16
  346.                             newR = aBitsIn(xIn + 2, yIn) + (5 * errR) / 16
  347.                             If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  348.                             If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  349.                             If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  350.                             aBitsIn(xIn + 0, yIn) = newB
  351.                             aBitsIn(xIn + 1, yIn) = newG
  352.                             aBitsIn(xIn + 2, yIn) = newR
  353.                             If (x < W) Then
  354.                                 xIn = 4 * x + 4
  355.                                 newB = aBitsIn(xIn + 0, yIn) + errB / 16
  356.                                 newG = aBitsIn(xIn + 1, yIn) + errG / 16
  357.                                 newR = aBitsIn(xIn + 2, yIn) + errR / 16
  358.                                 If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  359.                                 If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  360.                                 If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  361.                                 aBitsIn(xIn + 0, yIn) = newB
  362.                                 aBitsIn(xIn + 1, yIn) = newG
  363.                                 aBitsIn(xIn + 2, yIn) = newR
  364.                             End If
  365.                             If (x > 0) Then
  366.                                 xIn = 4 * x - 4
  367.                                 newB = aBitsIn(xIn + 0, yIn) + (3 * errB) / 16
  368.                                 newG = aBitsIn(xIn + 1, yIn) + (3 * errG) / 16
  369.                                 newR = aBitsIn(xIn + 2, yIn) + (3 * errR) / 16
  370.                                 If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
  371.                                 If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
  372.                                 If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
  373.                                 aBitsIn(xIn + 0, yIn) = newB
  374.                                 aBitsIn(xIn + 1, yIn) = newG
  375.                                 aBitsIn(xIn + 2, yIn) = newR
  376.                             End If
  377.                         End If
  378.                     End If
  379.                   Else
  380.                     aBitsIn(xIn + 0, y) = aPalette(lEntry + 0)
  381.                     aBitsIn(xIn + 1, y) = aPalette(lEntry + 1)
  382.                     aBitsIn(xIn + 2, y) = aPalette(lEntry + 2)
  383.                 End If
  384.             Next x
  385.         Next y
  386.         Call pvUnmapDIB(aBitsIn())
  387.         Call pvUnmapDIB(aBitsOut())
  388.     End If
  389. End Sub
  390.  
  391. '========================================================================================
  392. ' Private
  393. '========================================================================================
  394.  
  395. Private Sub pvMapDIB(oDIB As cDIB, aBits() As Byte, uSA As SAFEARRAY2D)
  396.     
  397.     With uSA
  398.         .cbElements = 1
  399.         .cDims = 2
  400.         .Bounds(0).lLbound = 0
  401.         .Bounds(0).cElements = oDIB.Height
  402.         .Bounds(1).lLbound = 0
  403.         .Bounds(1).cElements = oDIB.BytesPerScanline
  404.         .pvData = oDIB.lpBits
  405.     End With
  406.     Call CopyMemory(ByVal VarPtrArray(aBits()), VarPtr(uSA), 4)
  407. End Sub
  408.  
  409. Private Sub pvUnmapDIB(aBits() As Byte)
  410.  
  411.     Call CopyMemory(ByVal VarPtrArray(aBits()), 0&, 4)
  412. End Sub
  413.  
  414.