Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - Общий форум

Страница: 1 |

 

  Вопрос: BMP =>JPG Добавлено: 30.10.08 20:04  

Автор вопроса:  Stars
Есть у когогонить, маленький пример перевода из одного формата в другой?

Ответить

  Ответы Всего ответов: 3  

Номер ответа: 1
Автор ответа:
 



Администратор

ICQ: 278109632 

Вопросов: 42
Ответов: 3949
  Web-сайт: domkratt.com
 Профиль | | #1 		Добавлено: 30.10.08 20:24
http://www.google.ru/search?hl=ru&q=bmp+to+jpeg+VB

Ответить

Номер ответа: 2
Автор ответа:
 



Администратор

ICQ: 278109632 

Вопросов: 42
Ответов: 3949
  Web-сайт: domkratt.com
 Профиль | | #2 		Добавлено: 30.10.08 20:24
Миллион примеров для сотни контролов и библиотек...

Ответить

Номер ответа: 3
Автор ответа:
 Серёга



ICQ: 262809473 

Вопросов: 17
Ответов: 561
  Web-сайт: houselab.narod.ru
 Профиль | | #3 		Добавлено: 30.10.08 23:22
  1.  
  2. Option Explicit
  3. Option Base 0
  4.  
  5. 'Class Name:   cJpeg.cls  "JPEG Encoder Class"
  6. 'Author:       John Korejwa  <korejwa@tiac.net>
  7. 'Version:      0.9 beta  [26 / November / 2003]
  8. '
  9. '
  10. 'Legal:
  11. '        This class is intended for and was uploaded to www.planetsourcecode.com
  12. '
  13. '        This product includes JPEG compression code developed by John Korejwa.  <korejwa@tiac.net>
  14. '        Source code, written in Visual Basic, is freely available for non-commercial,
  15. '        non-profit use at www.planetsourcecode.com.
  16. '
  17. '
  18. 'Credits:
  19. '        Special thanks to Barry G., a government research scientist who took an interest in my
  20. '        steganography software and research in late 1999.  I never met Barry in person, but he
  21. '        was kind enough to buy and mail me a book with the ISO DIS 10918-1 JPEG standard.
  22. '
  23. '
  24. 'Description:  This class contains code for compressing pictures, sampled via hDC, into
  25. '              baseline .JPG files.  Please report any errors or unusual behavior to the email
  26. '              address above.
  27. '
  28. 'Dependencies: None
  29. '
  30.  
  31.  
  32. 'JPEG Marker Constants                (Note: VB compiler does not compile unused constants)
  33.                                       'Non-Differential Huffman Coding
  34. Private Const SOF0    As Long = &HC0& 'Baseline DCT
  35. Private Const SOF1    As Long = &HC1& 'Extended sequential DCT
  36. Private Const SOF2    As Long = &HC2& 'Progressive DCT
  37. Private Const SOF3    As Long = &HC3& 'Spatial (sequential) lossless
  38.                                       'Differential Huffman coding
  39. Private Const SOF5    As Long = &HC5& 'Differential sequential DCT
  40. Private Const SOF6    As Long = &HC6& 'Differential progressive DCT
  41. Private Const SOF7    As Long = &HC7& 'Differential spatial
  42.                                       'Non-Differential arithmetic coding
  43. Private Const jpg     As Long = &HC8& 'Reserved for JPEG extentions
  44. Private Const SOF9    As Long = &HC9& 'Extended sequential DCT
  45. Private Const SOF10   As Long = &HCA& 'Progressive DCT
  46. Private Const SOF11   As Long = &HCB& 'Spatial (sequential) lossless
  47.                                       'Differential arithmetic coding
  48. Private Const SOF13   As Long = &HCD& 'Differential sequential DCT
  49. Private Const SOF14   As Long = &HCE& 'Differential progressive DCT
  50. Private Const SOF15   As Long = &HCF& 'Differential Spatial
  51.                                       'Other Markers
  52. Private Const DHT     As Long = &HC4& 'Define Huffman tables
  53. Private Const DAC     As Long = &HCC& 'Define arithmetic coding conditioning(s)
  54. Private Const RSTm    As Long = &HD0& 'Restart with modulo 8 count "m"
  55. Private Const RSTm2   As Long = &HD7& 'to 'Restart with modulo 8 count "m"
  56. Private Const SOI     As Long = &HD8& 'Start of image
  57. Private Const EOI     As Long = &HD9& 'End of image
  58. Private Const SOS     As Long = &HDA& 'Start of scan
  59. Private Const DQT     As Long = &HDB& 'Define quantization table(s)
  60. Private Const DNL     As Long = &HDC& 'Define number of lines
  61. Private Const DRI     As Long = &HDD& 'Define restart interval
  62. Private Const DHP     As Long = &HDE& 'Define hierarchical progression
  63. Private Const EXP     As Long = &HDF& 'Expand reference components
  64. Private Const APP0    As Long = &HE0& 'Reserved for application segments
  65. Private Const APPF    As Long = &HEF& '  to Reserved for application segments
  66. Private Const JPGn    As Long = &HF0& 'Reserved for JPEG Extentions
  67. Private Const JPGn2   As Long = &HFD& '  to Reserved for JPEG Extentions
  68. Private Const COM     As Long = &HFE& 'Comment
  69. Private Const RESm    As Long = &H2&  'Reserved
  70. Private Const RESm2   As Long = &HBF& '  to Reserved
  71. Private Const TEM     As Long = &H1&  'For temporary use in arithmetic coding
  72.  
  73. 'Consider these arrays of constants.
  74. 'They are initialized with the class and do not change.
  75. Private QLumin(63)    As Integer 'Standard Luminance   Quantum (for 50% quality)
  76. Private QChrom(63)    As Integer 'Standard Chrominance Quantum (for 50% quality)
  77. Private FDCTScale(7)  As Double  'Constants for scaling FDCT Coefficients
  78. Private IDCTScale(7)  As Double  'Constants for scaling IDCT Coefficients
  79. Private ZigZag(7, 7)  As Long    'Zig Zag order of 8X8 block of samples
  80.  
  81. 'API constants
  82. Private Const BLACKONWHITE    As Long = 1 'nStretchMode constants for
  83. Private Const COLORONCOLOR    As Long = 3 '  SetStretchBltMode() API function
  84. Private Const HALFTONE        As Long = 4 'HALFTONE not supported in Win 95, 98, ME
  85.  
  86. Private Const BI_RGB          As Long = 0
  87. Private Const DIB_RGB_COLORS  As Long = 0
  88.  
  89.  
  90. 'Variable types needed for DIBSections.
  91. Private Type SAFEARRAYBOUND
  92.     cElements         As Long
  93.     lLbound           As Long
  94. End Type
  95. Private Type SAFEARRAY2D
  96.     cDims             As Integer
  97.     fFeatures         As Integer
  98.     cbElements        As Long
  99.     cLocks            As Long
  100.     pvData            As Long
  101.     Bounds(0 To 1)    As SAFEARRAYBOUND
  102. End Type
  103. Private Type RGBQUAD
  104.     rgbBlue           As Byte
  105.     rgbGreen          As Byte
  106.     rgbRed            As Byte
  107.     rgbReserved       As Byte
  108. End Type
  109. Private Type BITMAPINFOHEADER
  110.     biSize            As Long
  111.     biWidth           As Long
  112.     biHeight          As Long
  113.     biPlanes          As Integer
  114.     biBitCount        As Integer
  115.     biCompression     As Long
  116.     biSizeImage       As Long
  117.     biXPelsPerMeter   As Long
  118.     biYPelsPerMeter   As Long
  119.     biClrUsed         As Long
  120.     biClrImportant    As Long
  121. End Type
  122. Private Type BITMAPINFO
  123.     bmiHeader         As BITMAPINFOHEADER
  124.     bmiColors         As RGBQUAD
  125. End Type
  126.  
  127. 'API needed for creating DIBSections for sampling and pixel access.
  128. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  129. Private Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long   'lplpVoid changed to ByRef
  130. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  131. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  132. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  133. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  134. Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
  135. Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
  136. Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  137. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  138.  
  139. 'Custom variable types used for this JPEG encoding implementation
  140. Private Type QUANTIZATIONTABLE
  141.     Qk(63)            As Integer 'Quantization Values
  142.     FScale(63)        As Single  'Multiplication values to scale and Quantize   FDCT output
  143.     IScale(63)        As Single  'Multiplication values to scale and DeQuantize IDCT input
  144. End Type
  145. Private Type HUFFMANTABLE
  146.     Bits(15)          As Byte    'Number of huffman codes of length i+1
  147.     HUFFVAL(255)      As Byte    'Huffman symbol values
  148.     EHUFSI(255)       As Long    'Huffman code size for symbol i
  149.     EHUFCO(255)       As Long    'Huffman code      for symbol i
  150.     MINCODE(15)       As Long    '
  151.     MAXCODE(15)       As Long    'Largest code value for length i+1
  152. End Type
  153. Private Type COMPONENT
  154.     Ci                As Long    'Component ID                       [0-255]
  155.     Hi                As Long    'Horizontal Sampling Factor         [1-4]
  156.     Vi                As Long    'Vertical   Sampling Factor         [1-4]
  157.     Tqi               As Long    'Quantization Table Select          [0-3]
  158.     Data()            As Integer 'DCT Coefficients
  159. End Type
  160.  
  161. Private PP            As Long    'Sample Precision [8, 12]
  162. Private YY            As Long    'Number of lines             [Image Height]
  163. Private XX            As Long    'Number of samples per line  [Image Width]
  164. Private Nf            As Long    'Number of components in Frame
  165.  
  166. Private HMax          As Long    'Maximum horizontal sampling frequency
  167. Private VMax          As Long    'Maximum vertical   sampling frequency
  168.  
  169. Private m_Data()      As Byte    'JPEG File Data
  170. Private m_Chr         As Long    'Current Character in m_Data
  171. Private m_Ptr         As Long    'Byte index in m_Data
  172. Private m_Bit         As Long    'Bit  index in m_Chr
  173.  
  174. Private m_Block(7, 7) As Single  'Buffer for calculating DCT
  175.  
  176. Private QTable(3)     As QUANTIZATIONTABLE  '4 Quantization Tables
  177. Private HuffDC(3)     As HUFFMANTABLE       '4 DC Huffman Tables
  178. Private HuffAC(3)     As HUFFMANTABLE       '4 AC Huffman Tables
  179. Private Comp()        As COMPONENT          'Scan Components
  180.  
  181. Private m_Quality     As Long
  182. Private m_Comment     As String
  183.  
  184.  
  185.  
  186. '========================================================================================
  187. '              D I S C R E T E   C O S I N E   T R A N S F O R M A T I O N
  188. '========================================================================================
  189. Private Sub FDCT()
  190.     Static t0   As Single 'Given an 8X8 block of discretely sampled values [m_Block(0-7, 0-7)],
  191.     Static t1   As Single 'replace them with their (scaled) Forward Discrete Cosine Transformation values.
  192.     Static t2   As Single '80 (+64) multiplications and 464 additions are needed.
  193.     Static t3   As Single 'Values are scaled on output, meaning that each of the 64 elements must be
  194.     Static t4   As Single 'multiplied by constants for a final FDCT.  These final constants are combined
  195.     Static t5   As Single 'with Quantization constants, so a final 64 multiplications combine the
  196.     Static t6   As Single 'completion of the FDCT and Quantization in one step.
  197.     Static t7   As Single
  198.     Static t8   As Single
  199.     Static i    As Long
  200.  
  201.     For i = 0 To 7                  'Process 1D FDCT on each row
  202.         t0 = m_Block(i, 0) + m_Block(i, 7)
  203.         t1 = m_Block(i, 0) - m_Block(i, 7)
  204.         t2 = m_Block(i, 1) + m_Block(i, 6)
  205.         t3 = m_Block(i, 1) - m_Block(i, 6)
  206.         t4 = m_Block(i, 2) + m_Block(i, 5)
  207.         t5 = m_Block(i, 2) - m_Block(i, 5)
  208.         t6 = m_Block(i, 3) + m_Block(i, 4)
  209.         t7 = m_Block(i, 3) - m_Block(i, 4)
  210.  
  211.         t7 = t7 + t5
  212.         t8 = t0 - t6
  213.         t6 = t6 + t0
  214.         t0 = t2 + t4
  215.         t2 = (t2 - t4 + t8) * 0.707106781186548   'Cos(2# * PI / 8#)
  216.         t4 = t1 + t3
  217.         t3 = (t3 + t5) * 0.707106781186548        'Cos(2# * PI / 8#)
  218.         t5 = (t4 - t7) * 0.382683432365091        'Cos(3# * PI / 8#)
  219.         t7 = t7 * 0.541196100146196 - t5          'Cos(PI / 8#) - Cos(3# * PI / 8#)
  220.         t4 = t4 * 1.30656296487638 - t5           'Cos(PI / 8#) + Cos(3# * PI / 8#)
  221.         t5 = t1 + t3
  222.         t1 = t1 - t3
  223.  
  224.         m_Block(i, 0) = t6 + t0
  225.         m_Block(i, 4) = t6 - t0
  226.         m_Block(i, 1) = t5 + t4
  227.         m_Block(i, 7) = t5 - t4
  228.         m_Block(i, 2) = t8 + t2
  229.         m_Block(i, 6) = t8 - t2
  230.         m_Block(i, 5) = t1 + t7
  231.         m_Block(i, 3) = t1 - t7
  232.     Next i
  233.  
  234.     For i = 0 To 7                   'Process 1D FDCT on each column
  235.         t0 = m_Block(0, i) + m_Block(7, i)
  236.         t1 = m_Block(0, i) - m_Block(7, i)
  237.         t2 = m_Block(1, i) + m_Block(6, i)
  238.         t3 = m_Block(1, i) - m_Block(6, i)
  239.         t4 = m_Block(2, i) + m_Block(5, i)
  240.         t5 = m_Block(2, i) - m_Block(5, i)
  241.         t6 = m_Block(3, i) + m_Block(4, i)
  242.         t7 = m_Block(3, i) - m_Block(4, i)
  243.  
  244.         t7 = t7 + t5
  245.         t8 = t0 - t6
  246.         t6 = t6 + t0
  247.         t0 = t2 + t4
  248.         t2 = (t2 - t4 + t8) * 0.707106781186548   'Cos(2# * PI / 8#)
  249.         t4 = t1 + t3
  250.         t3 = (t3 + t5) * 0.707106781186548        'Cos(2# * PI / 8#)
  251.         t5 = (t4 - t7) * 0.382683432365091        'Cos(3# * PI / 8#)
  252.         t7 = t7 * 0.541196100146196 - t5          'Cos(PI / 8#) - Cos(3# * PI / 8#)
  253.         t4 = t4 * 1.30656296487638 - t5           'Cos(PI / 8#) + Cos(3# * PI / 8#)
  254.         t5 = t1 + t3
  255.         t1 = t1 - t3
  256.  
  257.         m_Block(0, i) = t6 + t0
  258.         m_Block(4, i) = t6 - t0
  259.         m_Block(1, i) = t5 + t4
  260.         m_Block(7, i) = t5 - t4
  261.         m_Block(2, i) = t8 + t2
  262.         m_Block(6, i) = t8 - t2
  263.         m_Block(5, i) = t1 + t7
  264.         m_Block(3, i) = t1 - t7
  265.     Next i
  266. End Sub
  267.  
  268.  
  269.  
  270.  
  271. '================================================================================
  272. '                 H U F F M A N   T A B L E   G E N E R A T I O N
  273. '================================================================================
  274. Private Sub OptimizeHuffman(TheHuff As HUFFMANTABLE, freq() As Long)
  275. 'Generate optimized values for BITS and HUFFVAL in a HUFFMANTABLE
  276. 'based on symbol frequency counts.  freq must be dimensioned freq(0-256)
  277. 'and contain counts of symbols 0-255.  freq is destroyed in this procedure.
  278.     Dim i              As Long
  279.     Dim j              As Long
  280.     Dim k              As Long
  281.     Dim n              As Long
  282.     Dim V1             As Long
  283.     Dim V2             As Long
  284.     Dim others(256)    As Long
  285.     Dim codesize(256)  As Long
  286.     Dim Bits(256)      As Long
  287.     Dim swp            As Long
  288.     Dim swp2           As Long
  289.  
  290.  
  291.     For i = 0 To 256  'Initialize others to -1, (this value terminates chain of indicies)
  292.         others(i) = -1
  293.     Next i
  294.     freq(256) = 1     'Add dummy symbol to guarantee no code will be all '1' bits
  295.  
  296.    'Generate codesize()   [find huffman code sizes]
  297.     Do 'do loop for (#non-zero-frequencies - 1) times
  298.         V1 = -1                            'find highest v1 for      least value of freq(v1)>0
  299.         V2 = -1                            'find highest v2 for next least value of freq(v2)>0
  300.         swp = 2147483647 'Max Long variable
  301.         swp2 = 2147483647
  302.         For i = 0 To 256
  303.             If freq(i) <> 0 Then
  304.                 If (freq(i) <= swp2) Then
  305.                     If (freq(i) <= swp) Then
  306.                         swp2 = swp
  307.                         V2 = V1
  308.                         swp = freq(i)
  309.                         V1 = i
  310.                     Else
  311.                         swp2 = freq(i)
  312.                         V2 = i
  313.                     End If
  314.                 End If
  315.             End If
  316.         Next i
  317.         If V2 = -1 Then
  318.             freq(V1) = 0 'all elements in freq are now set to zero
  319.             Exit Do      'done
  320.         End If
  321.         freq(V1) = freq(V1) + freq(V2)     'merge the two branches
  322.         freq(V2) = 0
  323.         codesize(V1) = codesize(V1) + 1    'Increment all codesizes in v1's branch
  324.         While (others(V1) >= 0)
  325.             V1 = others(V1)
  326.             codesize(V1) = codesize(V1) + 1
  327.         Wend
  328.         others(V1) = V2                    'chain v2 onto v1's branch
  329.         codesize(V2) = codesize(V2) + 1    'Increment all codesizes in v2's branch
  330.         While (others(V2) >= 0)
  331.             V2 = others(V2)
  332.             codesize(V2) = codesize(V2) + 1
  333.         Wend
  334.     Loop
  335.  
  336.    'Count BITS  [find the number of codes of each size]
  337.     n = 0
  338.     For i = 0 To 256
  339.         If codesize(i) <> 0 Then
  340.             Bits(codesize(i)) = Bits(codesize(i)) + 1
  341.             If n < codesize(i) Then n = codesize(i)    'Keep track of largest codesize
  342.         End If
  343.     Next i
  344.  
  345.    'Adjust BITS  [limit code lengths to 16 bits]
  346.     i = n
  347.     While i > 16
  348.         While Bits(i) > 0
  349.             For j = i - 2 To 1 Step -1        'Since symbols are paired for the longest Huffman
  350.                 If Bits(j) > 0 Then Exit For  'code, the symbols are removed from this length
  351.             Next j                            'category two at a time.  The prefix for the pair
  352.             Bits(i) = Bits(i) - 2             '(which is one bit shorter) is allocated to one
  353.             Bits(i - 1) = Bits(i - 1) + 1     'of the pair;  then, (skipping the BITS entry for
  354.             Bits(j + 1) = Bits(j + 1) + 2     'that prefix length) a code word from the next
  355.             Bits(j) = Bits(j) - 1             'shortest non-zero BITS entry is converted into
  356.         Wend                                  'a prefix for two code words one bit longer.
  357.         i = i - 1
  358.     Wend
  359.     Bits(i) = Bits(i) - 1                  'Remove dummy symbol code from the code length count
  360.  
  361.    'Copy BITS and HUFFVAL to the HUFFMANTABLE  [HUFFVAL sorted by code length, then by value]
  362.     With TheHuff
  363.         For i = 1 To 16
  364.             .Bits(i - 1) = Bits(i)
  365.         Next i
  366.         k = 0
  367.         For i = 1 To n
  368.             For j = 0 To 255
  369.                 If codesize(j) = i Then
  370.                     .HUFFVAL(k) = j
  371.                     k = k + 1
  372.                 End If
  373.             Next j
  374.         Next i
  375.     End With
  376.  
  377. End Sub
  378. Private Sub ExpandHuffman(TheHuff As HUFFMANTABLE, Optional MaxSymbol As Long = 255)
  379. 'Given a HUFFMANTABLE with valid BITS and HUFFVAL, generate tables for
  380. 'EHUFCO, EHUFSI, MAXCODE, and MINCODE so the table may be used for compression
  381. 'and/or decompression.  In JPEG, MaxSymbol is 255 for an AC Huffman Table.  For
  382. 'DC Tables, MaxSymbol is 11 for PP=8 bit precission, or 15 for PP=12 bit precission.
  383.     Dim i          As Long 'Index for BITS
  384.     Dim j          As Long 'Index for HUFFVAL
  385.     Dim k          As Long 'Index for last HUFFVAL of length (i+1)
  386.     Dim si         As Long 'Huffman code size  ( =2^i )
  387.     Dim code       As Long 'Huffman code
  388.     Dim symbol     As Long 'Huffman symbol
  389.  
  390.  
  391.     With TheHuff
  392.  
  393.         For i = 0 To 255
  394.            .EHUFSI(i) = 0      'Clear existing values so we can
  395.            .EHUFCO(i) = -1     'check for duplicate huffman symbols
  396.         Next i
  397.  
  398.         j = 0
  399.         si = 1
  400.         code = 0
  401.         For i = 0 To 15
  402.             k = j + .Bits(i)
  403.             If k > 256 Then Err.Raise 1, , "Bad Huffman Table" 'more than 256 symbols
  404.             If j = k Then 'no codes of length i+1
  405.                .MINCODE(i) = j - code
  406.                .MAXCODE(i) = -1
  407.             Else
  408.                .MINCODE(i) = j - code
  409.                 While j < k
  410.                     symbol = .HUFFVAL(j)  'read symbol, make sure it's valid
  411.                     If symbol > MaxSymbol Then Err.Raise 1, , "Bad Huffman Table"   'invalid symbol
  412.                     If .EHUFCO(symbol) >= 0 Then Err.Raise 1, , "Bad Huffman Table" 'duplicate symbol
  413.                    .EHUFSI(symbol) = si    'assign code for symbol
  414.                    .EHUFCO(symbol) = code
  415.                     code = code + 1
  416.                     j = j + 1
  417.                 Wend
  418.                .MAXCODE(i) = code - 1
  419.             End If
  420.             si = si * 2
  421.             If code >= si Then Err.Raise 1, , "Bad Huffman Table" 'code does not fit into available bits
  422.             code = code * 2
  423.         Next i
  424.         If j = 0 Then Err.Raise 1, , "Bad Huffman Table" 'No huffman symbols???
  425.     End With
  426.  
  427. End Sub
  428.  
  429.  
  430.  
  431.  
  432. '================================================================================
  433. '                           E N T R O P Y   C O D I N G
  434. '================================================================================
  435. Private Sub WriteBitsBegin()
  436.     m_Chr = 0
  437.     m_Bit = 128
  438. End Sub
  439. Private Sub WriteBitsEnd()
  440.     If m_Bit <> 128 Then WriteBits m_Bit, -1
  441. End Sub
  442. Private Sub WriteBits(ByVal si As Long, code As Long)
  443.     While si > 0
  444.         If (code And si) <> 0 Then m_Chr = (m_Chr Or m_Bit)
  445.         If m_Bit = 1 Then            'We completed a byte ...
  446.             m_Data(m_Ptr) = m_Chr    '    add it to the stream
  447.             If m_Chr = 255 Then      'Pad a zero byte and advance pointer
  448.                 m_Data(m_Ptr + 1) = 0
  449.                 m_Ptr = m_Ptr + 2
  450.             Else                     'just advance pointer
  451.                 m_Ptr = m_Ptr + 1
  452.             End If
  453.             m_Chr = 0                'clear byte buffer and reset bit index
  454.             m_Bit = 128
  455.         Else                         'increment to next bit position to write
  456.             m_Bit = m_Bit \ 2
  457.         End If
  458.         si = si \ 2
  459.     Wend
  460. End Sub
  461.  
  462. Private Sub EncodeCoefficients(Data() As Integer, P As Long, Pred As Long, Td As Long, Ta As Long)
  463. 'Use Huffman tables to compress a block of 64 quantized DCT coefficients to the local
  464. 'm_Data() byte array.  The coefficients are input in the data() array starting at index p.
  465. 'Pred is the predictor for the DC coefficient.  Td and Ta are indexes to the local DC and AC
  466. 'Huffman Tables to use.
  467.     Dim r     As Long
  468.     Dim rs    As Long
  469.     Dim si    As Long
  470.     Dim code  As Long
  471.     Dim p2    As Long
  472.  
  473.     p2 = P + 64
  474.  
  475.     code = Data(P) - Pred
  476.     Pred = Data(P)
  477.     P = P + 1
  478.  
  479.     si = 1
  480.     rs = 0
  481.     If code < 0 Then
  482.         Do While si <= -code
  483.             si = si * 2
  484.             rs = rs + 1
  485.         Loop
  486.         code = code - 1
  487.     Else
  488.         Do While si <= code
  489.             si = si * 2
  490.             rs = rs + 1
  491.         Loop
  492.     End If
  493.     si = si \ 2
  494.     WriteBits HuffDC(Td).EHUFSI(rs), HuffDC(Td).EHUFCO(rs) 'append symbol for size category
  495.     WriteBits si, code                                     'append diff
  496.  
  497.     With HuffAC(Ta)
  498.         r = 0
  499.         Do
  500.             If Data(P) = 0 Then
  501.                  r = r + 1
  502.             Else
  503.                 While r > 15
  504.                     WriteBits .EHUFSI(240), .EHUFCO(240) 'append RUN16 (a run of 16 zeros)
  505.                     r = r - 16
  506.                 Wend
  507.                 code = Data(P)
  508.                 rs = r * 16
  509.                 si = 1
  510.                 If code < 0 Then
  511.                     Do While si <= -code
  512.                         si = si * 2
  513.                         rs = rs + 1
  514.                     Loop
  515.                     code = code - 1
  516.                 Else
  517.                     Do While si <= code
  518.                         si = si * 2
  519.                         rs = rs + 1
  520.                     Loop
  521.                 End If
  522.                 si = si \ 2
  523.                 WriteBits .EHUFSI(rs), .EHUFCO(rs) 'append run length, size category
  524.                 WriteBits si, code                 'append AC value
  525.                 r = 0
  526.             End If
  527.             P = P + 1
  528.         Loop While P < p2 'should be equal on exit
  529.         If r <> 0 Then WriteBits .EHUFSI(0), .EHUFCO(0) 'append EOB (end of block)
  530.     End With
  531.  
  532. End Sub
  533.  
  534.  
  535.  
  536.  
  537. '========================================================================================
  538. '                      C O L L E C T I N G   S T A T I S T I C S
  539. '========================================================================================
  540. 'These procedures collect statistics of run-length and size categories of DCT coefficients
  541. 'so optimized Huffman tables can be generated to compress them.
  542. Private Sub CollectStatisticsAC(Data() As Integer, freqac() As Long)
  543.     Dim code As Long
  544.     Dim n    As Long 'Number of coefficients in data()
  545.     Dim P    As Long 'Index for current data() coefficient
  546.     Dim p2   As Long
  547.     Dim r    As Long 'Run length of zeros
  548.     Dim rs   As Long 'Run-length/Size-category Symbol
  549.  
  550.  
  551.     n = UBound(Data) + 1
  552.     P = 0
  553.     While P <> n
  554.         P = P + 1     'Skip DC coefficient
  555.         p2 = P + 63   '63 AC coefficients
  556.  
  557.         r = 0
  558.         While P <> p2
  559.             If Data(P) = 0 Then
  560.                  r = r + 1
  561.             Else
  562.                 While r > 15
  563.                     freqac(240) = freqac(240) + 1  'RUN16 Symbol
  564.                     r = r - 16
  565.                 Wend
  566.                 code = Data(P)
  567.                 If code < 0 Then 'rs = number of bits needed for code
  568.                     rs = Int((Log(-code) * 1.442695040889)) + 1   '1/log(2)  (+ error correction)
  569.                 ElseIf code > 0 Then
  570.                     rs = Int((Log(code) * 1.442695040889)) + 1    '1/log(2)  (+ error correction)
  571.                 Else
  572.                     rs = 0
  573.                 End If
  574.  
  575.                 rs = (r * 16) Or rs
  576.                 freqac(rs) = freqac(rs) + 1        'Run-length/Size-category Symbol
  577.                 r = 0
  578.             End If
  579.             P = P + 1
  580.         Wend
  581.         If r <> 0 Then freqac(0) = freqac(0) + 1   'EOB Symbol
  582.     Wend
  583.  
  584. End Sub
  585. Private Sub CollectStatisticsDCNonInterleaved(Data() As Integer, freqdc() As Long)
  586.     Dim Diff  As Long     'DC Difference
  587.     Dim Pred  As Long     'DC Predictor
  588.     Dim n     As Long     'Number of coefficients in data()
  589.     Dim P     As Long     'Index for current data() coefficient
  590.     Dim s     As Long     'Size category for Diff
  591.  
  592.  
  593.     n = UBound(Data) + 1
  594.     P = 0
  595.     Pred = 0
  596.     While P <> n
  597.         Diff = Data(P) - Pred
  598.         Pred = Data(P)
  599.  
  600.         If Diff < 0 Then 's = number of bits needed for Diff
  601.             s = Int((Log(-Diff) * 1.442695040889)) + 1   '1/log(2)  (+ error correction)
  602.         ElseIf Diff > 0 Then
  603.             s = Int((Log(Diff) * 1.442695040889)) + 1    '1/log(2) + (error correction)
  604.         Else
  605.             s = 0
  606.         End If
  607.  
  608.         freqdc(s) = freqdc(s) + 1
  609.         P = P + 64
  610.     Wend
  611.  
  612. End Sub
  613. Private Sub CollectStatisticsDCInterleaved(Data() As Integer, freqdc() As Long, Hi As Long, Vi As Long)
  614.     Dim P()       As Long     'Index to .data in component f for scanline g
  615.     Dim f         As Long      'Index counter  (component)
  616.     Dim g         As Long      'Index counter  (sampling factor, vertical)
  617.     Dim H         As Long      'Index counter  (sampling factor, horizontal)
  618.     Dim i         As Long      'Index counter  (MCU horizontal)
  619.     Dim j         As Long      'Index counter  (MCU vertical)
  620.     Dim n         As Long      'Number of coefficients in data()
  621.     Dim s         As Long      'Size category for Diff
  622.     Dim Diff      As Long      'DC Difference
  623.     Dim Pred      As Long      'DC Predictor
  624.     Dim pLF       As Long      'Line Feed for p in data
  625.     Dim MCUr      As Long      'Number of complete 8X8 blocks in rightmost MCU
  626.     Dim MCUx      As Long      'Number of MCUs per scanline
  627.     Dim MCUy      As Long      'Number of MCU scanlines
  628.  
  629.  
  630.     n = UBound(Data) + 1
  631.     ReDim P(Vi - 1)
  632.  
  633.  
  634.     MCUx = (XX + 8 * HMax - 1) \ (8 * HMax)
  635.     MCUy = (YY + 8 * VMax - 1) \ (8 * VMax)
  636.  
  637.     H = (-Int(-XX * Hi / HMax) + 7) \ 8  'Width of scanline in data (MCUs)
  638.  
  639.     For g = 0 To Vi - 1                  'Initialize .data pointers
  640.         P(g) = 64 * H * g
  641.     Next g
  642.     pLF = 64 * H * (Vi - 1)              'Initialize .data pointer advancer
  643.  
  644.     MCUr = (H Mod Hi)                    'Number of complete 8X8 Blocks in rightmost MCU
  645.     If MCUr = 0 Then MCUr = Hi
  646.  
  647.     For j = 1 To MCUy - 1
  648.  
  649.        'MCUs across a scanline
  650.         For i = 1 To MCUx - 1
  651.         For g = 1 To Vi
  652.         For H = 1 To Hi
  653.  
  654.         Diff = Data(P(g - 1)) - Pred
  655.         Pred = Data(P(g - 1))
  656.         P(g - 1) = P(g - 1) + 64
  657.         If Diff < 0 Then 's = number of bits needed for Diff
  658.             s = Int((Log(-Diff) * 1.442695040889)) + 1   '1/log(2)  (+ error correction)
  659.         ElseIf Diff > 0 Then
  660.             s = Int((Log(Diff) * 1.442695040889)) + 1    '1/log(2) + (error correction)
  661.         Else
  662.             s = 0
  663.         End If
  664.         freqdc(s) = freqdc(s) + 1
  665.  
  666.         Next H
  667.         Next g
  668.         Next i
  669.  
  670.        'Rightmost MCU
  671.         For g = 1 To Vi
  672.         For H = 1 To Hi
  673.         If H > MCUr Then  'Pad with dummy block
  674.             s = 0
  675.         Else
  676.             Diff = Data(P(g - 1)) - Pred
  677.             Pred = Data(P(g - 1))
  678.             P(g - 1) = P(g - 1) + 64
  679.  
  680.             If Diff < 0 Then
  681.                 s = Int((Log(-Diff) * 1.442695040889)) + 1
  682.             ElseIf Diff > 0 Then
  683.                 s = Int((Log(Diff) * 1.442695040889)) + 1
  684.             Else
  685.                 s = 0
  686.             End If
  687.         End If
  688.         freqdc(s) = freqdc(s) + 1
  689.         Next H
  690.         Next g
  691.  
  692.        'Advance data pointers
  693.         For g = 0 To Vi - 1
  694.             P(g) = P(g) + pLF
  695.         Next g
  696.     Next j
  697.  
  698.  
  699.    'Bottommost MCU Scanline
  700.     For i = 1 To MCUx
  701.     For g = 1 To Vi
  702.     For H = 1 To Hi
  703.     If P(g - 1) >= n Or (i = MCUx And H > MCUr) Then 'Pad with dummy block
  704.         s = 0
  705.     Else
  706.         Diff = Data(P(g - 1)) - Pred
  707.         Pred = Data(P(g - 1))
  708.         P(g - 1) = P(g - 1) + 64
  709.  
  710.         If Diff < 0 Then
  711.             s = Int((Log(-Diff) * 1.442695040889)) + 1
  712.         ElseIf Diff > 0 Then
  713.             s = Int((Log(Diff) * 1.442695040889)) + 1
  714.         Else
  715.             s = 0
  716.         End If
  717.     End If
  718.     freqdc(s) = freqdc(s) + 1
  719.     Next H
  720.     Next g
  721.     Next i
  722.  
  723. End Sub
  724.  
  725.  
  726.  
  727.  
  728. '========================================================================================
  729. '                                Q U A N T I Z A T I O N
  730. '========================================================================================
  731. Private Sub ExpandDQT(Tqi As Long)
  732.     Dim i          As Long
  733.     Dim j          As Long
  734.     Dim k          As Byte
  735.     Dim maxvalue   As Long
  736.  
  737.     With QTable(Tqi)
  738.         If PP = 12 Then
  739.             maxvalue = 65535
  740.         Else
  741.             maxvalue = 255
  742.         End If
  743.  
  744.         For i = 0 To 7
  745.             For j = 0 To 7
  746.                 k = ZigZag(i, j)
  747.                 If .Qk(k) < 1 Or .Qk(k) > maxvalue Then Err.Raise 1, , "Bad Quantization Table"
  748.                .FScale(k) = FDCTScale(i) * FDCTScale(j) / CDbl(.Qk(k))
  749.             Next j
  750.         Next i
  751.     End With
  752.  
  753. End Sub
  754. Private Sub Quantize(Data() As Integer, P As Long, FScale() As Single)
  755.     Dim i As Long  'Take 8X8 block of unscaled DCT coefficients [m_Block(0-7, 0-7)],
  756.     Dim j As Long  'Scale, Quantize, and store the results in data() array of
  757.     Dim T As Long  'COMPONENT in Zig Zag order at index p
  758.  
  759.  
  760.     For j = 0 To 7
  761.         For i = 0 To 7
  762.             T = ZigZag(i, j)
  763.             Data(P + T) = m_Block(i, j) * FScale(T)
  764.         Next i
  765.     Next j
  766.     P = P + 64
  767.  
  768. End Sub
  769. Friend Property Let Quality(vData As Long)
  770. 'The JPEG compression standard does not have a formal definition for image Quality.
  771. 'This implementation defines Quality as an integer value between 1 and 100, and
  772. 'generates quantization tables based on the value given.
  773. '
  774. 'Quality < 50  -  Poor image quality with high compression
  775. 'Quality = 75  -  Good quality pictures for displaying on a monitor or web page ... typical for general use
  776. 'Quality = 92  -  High quality with non-optimal compression ... Appropriate for printing ... [typical digital camera "max quality" setting]
  777. 'Quality > 95  -  Wasteful ... very poor compression with little image quality improvement.  Use 24-bit BMP TrueColor if you need quality this high.
  778.  
  779.     Dim i           As Long
  780.     Dim qvalue      As Long
  781.     Dim maxvalue    As Long
  782.     Dim scalefactor As Long
  783.  
  784.     maxvalue = 255 '32767 if 16 bit quantum is allowed
  785.  
  786.     If vData > 0 And vData <= 100 Then
  787.         m_Quality = vData
  788.  
  789.         If (m_Quality < 50) Then
  790.             If m_Quality <= 0 Then
  791.                 scalefactor = 5000
  792.             Else
  793.                 scalefactor = 5000 / m_Quality
  794.             End If
  795.         Else
  796.             If m_Quality > 100 Then
  797.                 scalefactor = 0
  798.             Else
  799.                 scalefactor = 200 - m_Quality * 2
  800.             End If
  801.         End If
  802.  
  803.         With QTable(0)
  804.             For i = 0 To 63
  805.                 qvalue = (QLumin(i) * scalefactor + 50) / 100
  806.                 If qvalue <= 0 Then
  807.                     qvalue = 1
  808.                 ElseIf qvalue > maxvalue Then
  809.                     qvalue = maxvalue
  810.                 End If
  811.                 .Qk(i) = qvalue
  812.             Next i
  813.         End With
  814.         With QTable(1)
  815.             For i = 0 To 63
  816.                 qvalue = (QChrom(i) * scalefactor + 50) / 100
  817.                 If qvalue <= 0 Then
  818.                     qvalue = 1
  819.                 ElseIf qvalue > maxvalue Then
  820.                     qvalue = maxvalue
  821.                 End If
  822.                 .Qk(i) = qvalue
  823.             Next i
  824.         End With
  825.  
  826.         ExpandDQT 0
  827.         ExpandDQT 1
  828.     End If
  829.  
  830. End Property
  831. Friend Property Get Quality() As Long
  832.     Quality = m_Quality
  833. End Property
  834.  
  835.  
  836.  
  837.  
  838.  
  839. '================================================================================
  840. '                           I M A G E   S A M P L I N G
  841. '================================================================================
  842. Friend Sub SetSamplingFrequencies(H1 As Long, V1 As Long, H2 As Long, V2 As Long, H3 As Long, V3 As Long)
  843.  
  844. 'This class always samples and compresses pictures in YCbCr colorspace.  The first component, Y,
  845. 'represents the Luminance of the pixels.  This is "how bright" a pixel is.  The Cb and Cr
  846. 'components are Chrominance, which is a measure of how far from neutral-white (toward a color)
  847. 'a pixel is.  The human visual sensory system can discriminate Luminance differences about
  848. 'twice as well as it can discriminate Chrominance differences.
  849. '
  850. 'Virtually all JPEG files are in YCbCr colorspace.  Other JPEG compliant colorspaces exist, but
  851. 'they are used in specialty equipment.  For example, people in the astronomy or medical fields
  852. 'choose colorspaces that best record the information they are interested in, and don't care about
  853. 'how pretty the picture looks to a person when displayed on a computer monitor.
  854. '[Apple/Machintosh sometimes uses a four component colorspace, but that colorspace is rare and
  855. 'not widely supported]
  856. '
  857. 'Sampling frequencies define how often each component is sampled.  Higher frequencies store more
  858. 'information, while lower frequencies store less.  Typically, sampling frequencies are set at
  859. '2,2, 1,1, 1,1.  This corresponds to the human visual sensory system.  The first component,
  860. 'Luminance, is sampled twice as much because our eyes notice differences in Luminance quite easily.
  861. 'The two Chrominance components are sampled half as much as because our eyes can't distinguish
  862. 'the difference in color changes as well.  One Luminance value is sampled for every pixel, and
  863. 'one Chrominance value is sampled for each 2X2 block of pixels.
  864. '
  865. 'Digital cameras typically record at sampling frequencies of 1,1, 1,1, 1,1.  This samples every
  866. 'pixel for all three components.  The quality of the picture is a little better when viewed by
  867. 'a person, but the compression benefits drop significantly.  If the picture to be compressed
  868. 'is from a Scanner or Digital camera, and you plan on printing it in the future, and storage
  869. 'space is not a problem, then sampling at these frequencies makes sense.  Otherwise, if you only
  870. 'plan on using the picture to display on a monitor or a web page, [2,2, 1,1, 1,1] makes the
  871. 'most sense.
  872. '
  873. 'The JPEG standard specifies that sampling frequencies may range from 1-4 for each component
  874. 'in both directions.  However, if any component has a sampling frequency of '3', and another
  875. 'component has a coresponding sampling frequency of '2' or '4', the downsampling process
  876. 'will map fractional pixels to sample values.  This is leagal in the JPEG standard, and this
  877. 'class will compress fractional pixel samplings, but this is not widely supported.  It is
  878. 'highly recommended to AVOID SAMPLING FACTORS OF 3 for maximum compatability with JPEG decoders.
  879. '
  880. 'Some JPEG encoders avoid the fractional pixel problem by only allowing the end user to pick
  881. 'a "sub-sampling" value.  In such "Sub Sampling" schemes, all Chrominance frequencies are set
  882. 'to one, and the (one or two) sub-sampling value(s) specify Luminance frequencies.
  883. '
  884. 'There should *never* be an error raised if you are using this class correctly.  It should
  885. 'not be possible for the end user to specify illegal sampling frequency values!
  886. '[For tinkerers - If you delete the error raising code and specify illegal sampling
  887. 'frequencies, this class will procede to create a non-JPEG compliant file with the values
  888. 'specified]
  889.  
  890.     Dim i As Long
  891.  
  892.     If H1 < 1 Or H1 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
  893.     If V1 < 1 Or V1 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
  894.  
  895.     If (H2 Or H3 Or V2 Or V3) = 0 Then  'if H2,H3,V2,V3 are all zero ...
  896.         Nf = 1         'Luminance only.
  897.         ReDim Comp(0)
  898.         Comp(0).Hi = 1 'Set up for sampling Greyscale
  899.         Comp(0).Vi = 1 '(Black and White picture)
  900.     Else
  901.         If H2 < 1 Or H2 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
  902.         If H3 < 1 Or H3 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
  903.         If V2 < 1 Or V2 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
  904.         If V3 < 1 Or V3 > 4 Then Err.Raise 1, , "Invalid Sampling Value"
  905.         Nf = 3         'YCbCr
  906.         ReDim Comp(2)
  907.         Comp(0).Hi = H1
  908.         Comp(0).Vi = V1
  909.         Comp(0).Tqi = 0
  910.         Comp(1).Hi = H2
  911.         Comp(1).Vi = V2
  912.         Comp(1).Tqi = 1
  913.         Comp(2).Hi = H3
  914.         Comp(2).Vi = V3
  915.         Comp(2).Tqi = 1
  916.     End If
  917.  
  918.     HMax = -1
  919.     VMax = -1
  920.     For i = 0 To Nf - 1 'determine max h, v sampling factors
  921.         If HMax < Comp(i).Hi Then HMax = Comp(i).Hi
  922.         If VMax < Comp(i).Vi Then VMax = Comp(i).Vi
  923.     Next i
  924.  
  925. End Sub
  926.  
  927. Friend Function SampleHDC(ByVal lHDC As Long, lWidth As Long, lHeight As Long, Optional lSrcLeft As Long, Optional lSrcTop As Long) As Long
  928. 'Given a valid hDC and dimensions, generate component samplings of an Image.
  929. 'A DIBSection is created to hold Sample(s) of the Image, from which the Image is
  930. 'decomposed into YCbCr components.
  931. 'Returns: 0 = Success
  932. '         1 = API error while generating a DIBSection
  933.     Dim hDIb       As Long    'Handle to the DIBSection
  934.     Dim hBmpOld    As Long    'Handle to the old bitmap in the DC, for clear up
  935.     Dim hdc        As Long    'Handle to the Device context holding the DIBSection
  936.     Dim lPtr       As Long    'Address of memory pointing to the DIBSection's bits
  937.     Dim BI         As BITMAPINFO 'Type containing the Bitmap information
  938.     Dim sA         As SAFEARRAY2D
  939.     Dim Pixel()    As Byte   'Byte array containing pixel data
  940.     Dim f          As Long   'Index counter for components
  941.     Dim qp         As Long   'Index for quantized FDCT value (in component data)
  942.     Dim rm         As Single 'Scale factor for red   pixel when converting RGB->YCbCr
  943.     Dim gm         As Single 'Scale factor for green pixel when converting RGB->YCbCr
  944.     Dim bm         As Single 'Scale factor for blue  pixel when converting RGB->YCbCr
  945.     Dim s          As Single 'Level shift value             for converting RGB->YCbCr
  946.     Dim xi         As Long   'Sample width
  947.     Dim yi         As Long   'Sample height
  948.     Dim xi2        As Long   'Sample width  (for previous component)
  949.     Dim yi2        As Long   'Sample height (for previous component)
  950.     Dim xi8        As Long   'Sample width  (padded to 8 pixel barrier)
  951.     Dim yi8        As Long   'Sample height (padded to 8 pixel barrier)
  952.     Dim i0         As Long   'Left index of an 8X8 block of pixels
  953.     Dim j0         As Long   'Top  index of an 8X8 block of pixels
  954.     Dim i          As Long   'Pixel Index (Horizontal)
  955.     Dim j          As Long   'Pixel Index (Vertical)
  956.     Dim P          As Long   'DCT Index (horizontal)
  957.     Dim q          As Long   'DCT Index (vertical)
  958.  
  959.  
  960.     PP = 8
  961.     YY = lHeight
  962.     XX = lWidth
  963.  
  964.    'Create a DIBSection to store Sampling(s) of the Image
  965.     hdc = CreateCompatibleDC(0)
  966.     If hdc = 0 Then
  967.         SampleHDC = 1 'CreateCompatibleDC() API Failure
  968.     Else
  969.         With BI.bmiHeader
  970.             .biSize = Len(BI.bmiHeader)
  971.             .biWidth = (lWidth + 7) And &HFFFFFFF8   '8 byte barrier for 8X8 data units
  972.             .biHeight = (lHeight + 7) And &HFFFFFFF8
  973.             .biPlanes = 1
  974.             .biBitCount = 24
  975.             .biCompression = BI_RGB
  976.             .biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight '4 byte barrier
  977.         End With
  978.         hDIb = CreateDIBSection2(hdc, BI, DIB_RGB_COLORS, lPtr, 0, 0)
  979.         If hDIb = 0 Then
  980.             SampleHDC = 1 'CreateDIBSection2() API Failure
  981.         Else
  982.             With sA                        'This code copies the pointer of the 2-D bitmap
  983.                 .cbElements = 1            'pixel data to the pointer of the Pixel() array.
  984.                 .cDims = 2                 'This allows you to read/modify the pixel data
  985.                 .Bounds(0).lLbound = 0     'as if it were stored in the Pixel() array.
  986.                 .Bounds(0).cElements = BI.bmiHeader.biHeight
  987.                 .Bounds(1).lLbound = 0
  988.                 .Bounds(1).cElements = ((BI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC)
  989.                 .pvData = lPtr             'Note that this is extreamly efficient, since it copies
  990.             End With                       'a pointer to the data, and not the data itself.
  991.             hBmpOld = SelectObject(hdc, hDIb) 'Select DIBSection into DC
  992.             If SetStretchBltMode(hdc, HALFTONE) = 0 Then SetStretchBltMode hdc, COLORONCOLOR
  993.  
  994.  
  995.     For f = 0 To Nf - 1
  996.         Select Case f 'Select scaling factors for RGB->YCbCr conversion for this component
  997.         Case 0 'Luminance
  998.             rm = 0.299
  999.             gm = 0.587
  1000.             bm = 0.114
  1001.             s = -128
  1002.         Case 1 'Chrominance [Blue-Yellow]
  1003.             rm = -0.16874
  1004.             gm = -0.33126
  1005.             bm = 0.5
  1006.             s = 0
  1007.         Case 2 'Chrominance [Red-Green]
  1008.             rm = 0.5
  1009.             gm = -0.41869
  1010.             bm = -0.08131
  1011.             s = 0
  1012.         End Select
  1013.  
  1014.         With Comp(f)
  1015.            .Ci = f + 1 'Assign an ID to this component
  1016.  
  1017.             xi = -Int(-XX * .Hi / HMax)        'determine Sample dimensions
  1018.             yi = -Int(-YY * .Vi / VMax)
  1019.             xi8 = ((xi + 7) And &HFFFFFFF8)    'Sample dimensions with 8X8 barrier
  1020.             yi8 = ((yi + 7) And &HFFFFFFF8)
  1021.             ReDim .Data(xi8 * yi8 - 1)
  1022.  
  1023.             If xi8 <> xi2 Or yi8 <> yi2 Then  'We need to Sample the Image
  1024.                 If xi = XX And yi = YY Then 'Just copy the image to our DIBSection
  1025.                     BitBlt hdc, 0, BI.bmiHeader.biHeight - yi8, xi, yi, lHDC, lSrcLeft, lSrcTop, vbSrcCopy
  1026.                 Else                        'Resample/Resize the Image
  1027.                     StretchBlt hdc, 0, BI.bmiHeader.biHeight - yi8, xi, yi, lHDC, lSrcLeft, lSrcTop, lWidth, lHeight, vbSrcCopy
  1028.                 End If
  1029.                 For i = xi To xi8 - 1  'Pad right of Sample to 8 block barrier
  1030.                     BitBlt hdc, i, BI.bmiHeader.biHeight - yi8, 1, yi, hdc, i - 1, BI.bmiHeader.biHeight - yi8, vbSrcCopy
  1031.                 Next i
  1032.                 For j = BI.bmiHeader.biHeight - (yi8 - yi) To BI.bmiHeader.biHeight - 1 'Pad bottom of Sample to 8 block barrier
  1033.                     BitBlt hdc, 0, j, xi8, 1, hdc, 0, j - 1, vbSrcCopy
  1034.                 Next j
  1035.             End If
  1036.             xi2 = xi8
  1037.             yi2 = yi8
  1038.             qp = 0 'Reset output Quantized FDCT Coefficient Index
  1039.  
  1040.            'Read 8X8 blocks of pixels, convert from RGB->YCbCr colorspace, FDCT and Quantize
  1041.            'the data, store the results in .data of this component
  1042.             CopyMemory ByVal VarPtrArray(Pixel), VarPtr(sA), 4& 'Get Pixel array descriptor
  1043.             j = yi8 - 1
  1044.             While j > 0               'Scan from top to bottom (j = -1 after loop)
  1045.                 i = 0
  1046.                 j0 = j
  1047.                 While i < 3 * xi8     'Scan from left to right (i = 3*xi8 after loop)
  1048.                     j = j0
  1049.                     i0 = i
  1050.                     For P = 0 To 7    'Get 8X8 block of level shifted YCbCr values
  1051.                         i = i0
  1052.                         For q = 0 To 7
  1053.                             m_Block(q, P) = rm * Pixel(i + 2, j) + _
  1054.                                             gm * Pixel(i + 1, j) + _
  1055.                                             bm * Pixel(i, j) + s
  1056.                             i = i + 3
  1057.                         Next q
  1058.                         j = j - 1
  1059.                     Next P
  1060.                     FDCT                               'Calculate the FDCT
  1061.                     Quantize .Data, qp, QTable(.Tqi).FScale   'Quantize, and store in DCT buffer
  1062.                 Wend
  1063.             Wend
  1064.             CopyMemory ByVal VarPtrArray(Pixel), 0&, 4 'Clear the Pixel array descriptor
  1065.         End With
  1066.     Next f
  1067.  
  1068.  
  1069.             SelectObject hdc, hBmpOld 'Select CompatibleDC  (unselect DIBSection)
  1070.             DeleteObject hDIb         'Delete DIBSection
  1071.         End If
  1072.         DeleteObject hdc              'Delete CompatibleDC
  1073.     End If
  1074.  
  1075. End Function
  1076.  
  1077.  
  1078.  
  1079. Friend Property Let Comment(Value As String)
  1080.    'Assigning a value to this property will add the text Comment to the JPEG file.
  1081.     If Len(Value) > 65535 Then Err.Raise 1, , "Illegal Comment Length"
  1082.     m_Comment = Value
  1083. End Property
  1084. Friend Property Get Comment() As String
  1085.     Comment = m_Comment
  1086. End Property
  1087.  
  1088.  
  1089.  
  1090.  
  1091. '================================================================================
  1092. '                         E M I T I N G   M A R K E R S
  1093. '================================================================================
  1094. Private Sub InsertJFIF()
  1095.     If m_Ptr + 17 > UBound(m_Data) Then Err.Raise 9 'Copymemory will write past bounds of m_Data()
  1096.  
  1097.     CopyMemory m_Data(m_Ptr + 0), &H1000E0FF, 4&    'APP0 Marker, Length(APP0)=16
  1098.     CopyMemory m_Data(m_Ptr + 4), &H4649464A, 4&    '"JFIF"
  1099.     CopyMemory m_Data(m_Ptr + 8), &H10100, 4&       '"/0", Version Major=1, Version Minor=1
  1100.                                                     'Units=0  [0=pixel, 1=dpi, 2=dots/cm]
  1101.     CopyMemory m_Data(m_Ptr + 12), &H1000100, 4&    'Horizontal pixel density = 1 (dot per pixel)
  1102.                                                     'Vertical   pixel density = 1 (dot per pixel)
  1103.     CopyMemory m_Data(m_Ptr + 16), &H0&, 2&         'Thumbnail horizontal pixel count = 0
  1104.     m_Ptr = m_Ptr + 18                              'Thumbnail vertical   pixel count = 0
  1105.  
  1106. End Sub
  1107. Private Sub InsertSOF(SOFMarker As Long)
  1108.     Dim i   As Long 'Insert a Start Of Frame marker segment
  1109.     Dim Lx  As Long 'PP, YY, XX, Nf, and Ci,Hi,Vi,Tqi, must already be set
  1110.  
  1111.     Lx = 8 + 3 * Nf
  1112.     m_Data(m_Ptr) = 255                    'SOF
  1113.     m_Data(m_Ptr + 1) = SOFMarker And 255
  1114.     m_Data(m_Ptr + 2) = Lx \ 256           'Frame Header Length
  1115.     m_Data(m_Ptr + 3) = Lx And 255
  1116.     m_Data(m_Ptr + 4) = PP                 'Sample precision [8, 12]
  1117.     m_Data(m_Ptr + 5) = YY \ 256           'Number of Lines
  1118.     m_Data(m_Ptr + 6) = YY And 255
  1119.     m_Data(m_Ptr + 7) = XX \ 256           'Number of samples per line
  1120.     m_Data(m_Ptr + 8) = XX And 255
  1121.     m_Data(m_Ptr + 9) = Nf                 'Number of image components in frame
  1122.     m_Ptr = m_Ptr + 10
  1123.     For i = 0 To Nf - 1                      'For each component ...
  1124.         With Comp(i)
  1125.             m_Data(m_Ptr) = .Ci                  'Component identifier
  1126.             m_Data(m_Ptr + 1) = .Hi * 16 Or .Vi  'Horizontal/Vertical sampling factors
  1127.             m_Data(m_Ptr + 2) = .Tqi             'Quantization table selector
  1128.         End With
  1129.         m_Ptr = m_Ptr + 3
  1130.     Next i
  1131. End Sub
  1132. Private Sub InsertCOM(TheComment As String)
  1133.     Dim i As Long
  1134.     Dim Lx As Long
  1135.  
  1136.     Lx = Len(TheComment) + 2
  1137.     If Lx > 2 Then
  1138.         m_Data(m_Ptr) = 255               'COM marker
  1139.         m_Data(m_Ptr + 1) = COM
  1140.         m_Data(m_Ptr + 2) = Lx \ 256      'COM marker segment length
  1141.         m_Data(m_Ptr + 3) = Lx And 255
  1142.         m_Ptr = m_Ptr + 4
  1143.         For i = 1 To Len(TheComment)      'Comment text
  1144.             m_Data(m_Ptr) = Asc(Mid$(TheComment, i, 1))
  1145.             m_Ptr = m_Ptr + 1
  1146.         Next i
  1147.     End If
  1148. End Sub
  1149. Private Sub InsertDQT(ByVal MarkerPos As Long, Tqi As Long)
  1150.     Dim i As Long 'Call with MarkerPos = m_Ptr to insert a single table with its own DQT marker
  1151.                   'Call multiple times with the same MarkerPos to include
  1152.                   'multiple tables under the same DQT marker
  1153.  
  1154.     If m_Ptr < MarkerPos + 4 Then 'Insert Marker
  1155.         m_Ptr = MarkerPos + 4
  1156.         m_Data(m_Ptr - 4) = 255
  1157.         m_Data(m_Ptr - 3) = DQT
  1158.     End If
  1159.     With QTable(Tqi)
  1160.         For i = 0 To 63
  1161.             If .Qk(i) > 255 Then Exit For
  1162.         Next i
  1163.         If i = 64 Then              '8 bit precision
  1164.             m_Data(m_Ptr) = Tqi
  1165.             m_Ptr = m_Ptr + 1
  1166.             For i = 0 To 63
  1167.                 m_Data(m_Ptr) = .Qk(i)
  1168.                 m_Ptr = m_Ptr + 1
  1169.             Next i
  1170.         Else                        '16 bit precision
  1171.             If PP <> 12 Then Err.Raise 1, , "Illegal precission in Quantization Table"
  1172.             m_Data(m_Ptr) = Tqi Or 16
  1173.             m_Ptr = m_Ptr + 1
  1174.             For i = 0 To 63
  1175.                 m_Data(m_Ptr) = .Qk(i) \ 256
  1176.                 m_Data(m_Ptr + 1) = .Qk(i) And 255
  1177.                 m_Ptr = m_Ptr + 2
  1178.             Next i
  1179.         End If
  1180.     End With
  1181.  
  1182.     m_Data(MarkerPos + 2) = (m_Ptr - MarkerPos - 2) \ 256& 'Insert Marker segment length
  1183.     m_Data(MarkerPos + 3) = (m_Ptr - MarkerPos - 2) And 255&
  1184. End Sub
  1185. Private Sub InsertDHT(ByVal MarkerPos As Long, HIndex As Long, IsAC As Boolean)
  1186.     Dim i As Long 'Call with MarkerPos = m_Ptr to insert a single table with its own DHT marker
  1187.     Dim j As Long 'Call multiple times with the same MarkerPos to include
  1188.                   'multiple tables under the same DHT marker
  1189.  
  1190.     If m_Ptr < MarkerPos + 4 Then 'Insert Marker
  1191.         m_Ptr = MarkerPos + 4
  1192.         m_Data(m_Ptr - 4) = 255
  1193.         m_Data(m_Ptr - 3) = DHT
  1194.     End If
  1195.     If IsAC Then
  1196.         With HuffAC(HIndex)
  1197.             m_Data(m_Ptr) = HIndex Or 16
  1198.             m_Ptr = m_Ptr + 1
  1199.             j = 0
  1200.             For i = 0 To 15
  1201.                 m_Data(m_Ptr) = .Bits(i)
  1202.                 m_Ptr = m_Ptr + 1
  1203.                 j = j + .Bits(i)
  1204.             Next i
  1205.             For i = 0 To j - 1
  1206.                 m_Data(m_Ptr) = .HUFFVAL(i)
  1207.                 m_Ptr = m_Ptr + 1
  1208.             Next i
  1209.         End With
  1210.     Else
  1211.         With HuffDC(HIndex)
  1212.             m_Data(m_Ptr) = HIndex
  1213.             m_Ptr = m_Ptr + 1
  1214.             j = 0
  1215.             For i = 0 To 15
  1216.                 m_Data(m_Ptr) = .Bits(i)
  1217.                 m_Ptr = m_Ptr + 1
  1218.                 j = j + .Bits(i)
  1219.             Next i
  1220.             For i = 0 To j - 1
  1221.                 m_Data(m_Ptr) = .HUFFVAL(i)
  1222.                 m_Ptr = m_Ptr + 1
  1223.             Next i
  1224.         End With
  1225.     End If
  1226.  
  1227.     m_Data(MarkerPos + 2) = (m_Ptr - MarkerPos - 2) \ 256& 'Insert Marker segment length
  1228.     m_Data(MarkerPos + 3) = (m_Ptr - MarkerPos - 2) And 255&
  1229. End Sub
  1230. Private Sub InsertMarker(TheMarker As Long)
  1231.     m_Data(m_Ptr) = 255
  1232.     m_Data(m_Ptr + 1) = TheMarker
  1233.     m_Ptr = m_Ptr + 2
  1234. End Sub
  1235.  
  1236.  
  1237.  
  1238.  
  1239. '================================================================================
  1240. '                           E M I T I N G   S C A N S
  1241. '================================================================================
  1242. Private Sub InsertSOSNonInterleaved(CompIndex As Long, Td As Long, Ta As Long)
  1243. 'Insert an SOS marker and scan data for a non-interleaved Sequential scan.
  1244.     Dim P         As Long     'Index to .data in component
  1245.     Dim n         As Long
  1246.     Dim Pred      As Long     'Predictor for DC coefficient
  1247.  
  1248.  
  1249.    'Insert SOS Marker Segment
  1250.     m_Data(m_Ptr) = 255                          'SOS Marker
  1251.     m_Data(m_Ptr + 1) = SOS
  1252.     m_Data(m_Ptr + 2) = 8 \ 256                  'Marker Segment Length
  1253.     m_Data(m_Ptr + 3) = 8 And 255
  1254.     m_Data(m_Ptr + 4) = 1                        'Ns     - Number of components in Scan [1-4]
  1255.     m_Ptr = m_Ptr + 5
  1256.     m_Data(m_Ptr) = Comp(CompIndex).Ci           'Csj    - Component ID
  1257.     m_Data(m_Ptr + 1) = Td * 16 Or Ta            'Td, Ta - DC, AC entropy coder selector
  1258.     m_Ptr = m_Ptr + 2
  1259.     m_Data(m_Ptr) = 0                            'Ss     - Start of spectral selection
  1260.     m_Data(m_Ptr + 1) = 63                       'Se     - End of spectral selection
  1261.     m_Data(m_Ptr + 2) = 0                        'Ah, Al - Successive approximation bit high/low
  1262.     m_Ptr = m_Ptr + 3
  1263.  
  1264.    'Insert non-interleaved sequential entropy coded data
  1265.     With Comp(CompIndex)
  1266.  
  1267.         P = 0
  1268.         n = UBound(.Data) + 1
  1269.         Pred = 0
  1270.  
  1271.         WriteBitsBegin
  1272.         While P <> n
  1273.             EncodeCoefficients .Data, P, Pred, Td, Ta
  1274.         Wend
  1275.         WriteBitsEnd
  1276.  
  1277.     End With
  1278.  
  1279. End Sub
  1280.  
  1281. Private Sub InsertSOSInterleaved(CompIndex() As Long, Td() As Long, Ta() As Long, FirstIndex As Long, SecondIndex As Long)
  1282. 'Insert an SOS marker and scan data for an interleaved Sequential scan.
  1283.  
  1284.     Dim f         As Long      'Index counter  (component)
  1285.     Dim g         As Long      'Index counter  (sampling factor, vertical)
  1286.     Dim H         As Long      'Index counter  (sampling factor, horizontal)
  1287.     Dim i         As Long      'Index counter  (MCU horizontal)
  1288.     Dim j         As Long      'Index counter  (MCU vertical)
  1289.     Dim Lx        As Long      'Marker Segment Length
  1290.     Dim Ns        As Long      'Number of components in Scan [1-4]
  1291.     Dim MCUx      As Long      'Number of MCUs per scanline
  1292.     Dim MCUy      As Long      'Number of MCU scanlines
  1293.  
  1294.     Dim P()        As Long     'Index to .data in component f for scanline g
  1295.     Dim pLF()      As Long     'Line Feed for p in .data for component f
  1296.     Dim Pred()     As Long     'Predictor for DC coefficient in component f
  1297.     Dim MCUr()     As Long     'Number of complete 8X8 blocks in rightmost MCU for component f
  1298.     Dim Pad64(63)  As Integer  '8X8 padding block for completing MCUs
  1299.  
  1300.  
  1301.     Ns = SecondIndex - FirstIndex + 1
  1302.     Lx = 6 + 2 * Ns
  1303.  
  1304.    'Insert SOS Marker Segment
  1305.     m_Data(m_Ptr) = 255                          'SOS Marker
  1306.     m_Data(m_Ptr + 1) = SOS
  1307.     m_Data(m_Ptr + 2) = Lx \ 256                 'Marker Segment Length
  1308.     m_Data(m_Ptr + 3) = Lx And 255
  1309.     m_Data(m_Ptr + 4) = Ns                       'Ns     - Number of components in Scan [1-4]
  1310.     m_Ptr = m_Ptr + 5
  1311.     For i = FirstIndex To SecondIndex
  1312.         m_Data(m_Ptr) = Comp(CompIndex(i)).Ci   'Csj
  1313.         m_Data(m_Ptr + 1) = Td(i) * 16 Or Ta(i) 'Td, Ta
  1314.         m_Ptr = m_Ptr + 2
  1315.     Next i
  1316.     m_Data(m_Ptr) = 0                            'Ss     - Start of spectral selection
  1317.     m_Data(m_Ptr + 1) = 63                       'Se     - End of spectral selection
  1318.     m_Data(m_Ptr + 2) = 0                        'Ah, Al - Successive approximation bit high/low
  1319.     m_Ptr = m_Ptr + 3
  1320.  
  1321.  
  1322.    'Insert interleaved sequential entropy coded data
  1323.     ReDim P(FirstIndex To SecondIndex, VMax - 1)
  1324.     ReDim Pred(FirstIndex To SecondIndex)
  1325.     ReDim pLF(FirstIndex To SecondIndex)
  1326.     ReDim MCUr(FirstIndex To SecondIndex)
  1327.  
  1328.     MCUx = (XX + 8 * HMax - 1) \ (8 * HMax)
  1329.     MCUy = (YY + 8 * VMax - 1) \ (8 * VMax)
  1330.  
  1331.     For f = FirstIndex To SecondIndex
  1332.         With Comp(CompIndex(f))
  1333.             H = (-Int(-XX * .Hi / HMax) + 7) \ 8  'Width of scanline in .data (MCUs)
  1334.  
  1335.             For g = 0 To .Vi - 1                  'Initialize .data pointers
  1336.                 P(f, g) = 64 * H * g
  1337.             Next g
  1338.             pLF(f) = 64 * H * (.Vi - 1)           'Initialize .data pointer advancer
  1339.  
  1340.             MCUr(f) = (H Mod .Hi)                 'Number of complete 8X8 Blocks in rightmost MCU
  1341.             If MCUr(f) = 0 Then MCUr(f) = .Hi
  1342.         End With
  1343.     Next f
  1344.  
  1345.     WriteBitsBegin
  1346.     For j = 1 To MCUy - 1
  1347.  
  1348.        'Encode MCUs across a scanline
  1349.         For i = 1 To MCUx - 1
  1350.         For f = FirstIndex To SecondIndex '0 To Ns - 1
  1351.         With Comp(CompIndex(f))
  1352.         For g = 1 To .Vi
  1353.         For H = 1 To .Hi
  1354.         EncodeCoefficients .Data, P(f, g - 1), Pred(f), Td(f), Ta(f)
  1355.         Next H
  1356.         Next g
  1357.         End With
  1358.         Next f
  1359.         Next i
  1360.  
  1361.        'Encode Rightmost MCU
  1362.         For f = FirstIndex To SecondIndex '0 To Ns - 1
  1363.         With Comp(CompIndex(f))
  1364.         For g = 1 To .Vi
  1365.         For H = 1 To .Hi
  1366.         If H > MCUr(f) Then 'Pad with dummy block
  1367.             Pad64(0) = Pred(f)
  1368.             EncodeCoefficients Pad64, 0, Pred(f), Td(f), Ta(f)
  1369.         Else
  1370.             EncodeCoefficients .Data, P(f, g - 1), Pred(f), Td(f), Ta(f)
  1371.         End If
  1372.         Next H
  1373.         Next g
  1374.         End With
  1375.         Next f
  1376.  
  1377.        'Advance .data pointers
  1378.         For f = FirstIndex To SecondIndex
  1379.         For g = 0 To Comp(CompIndex(f)).Vi - 1
  1380.         P(f, g) = P(f, g) + pLF(f)
  1381.         Next g
  1382.         Next f
  1383.      Next j
  1384.  
  1385.    'Encode Bottommost MCU Scanline
  1386.     For i = 1 To MCUx
  1387.     For f = FirstIndex To SecondIndex
  1388.     With Comp(CompIndex(f))
  1389.     For g = 1 To .Vi
  1390.     For H = 1 To .Hi
  1391.     If P(f, g - 1) > UBound(.Data) Or (i = MCUx And H > MCUr(f)) Then 'Pad with dummy block
  1392.         Pad64(0) = Pred(f)
  1393.         EncodeCoefficients Pad64, 0, Pred(f), Td(f), Ta(f)
  1394.     Else
  1395.         EncodeCoefficients .Data, P(f, g - 1), Pred(f), Td(f), Ta(f)
  1396.     End If
  1397.     Next H
  1398.     Next g
  1399.     End With
  1400.     Next f
  1401.     Next i
  1402.  
  1403.     WriteBitsEnd
  1404.  
  1405. End Sub
  1406.  
  1407. Private Sub InsertSequentialScans(CompIndex() As Long, Td() As Long, Ta() As Long, FirstIndex As Long, SecondIndex As Long)
  1408. 'Insert scan components CompIndex(FirstIndex) to CompIndex(SecondIndex) sequentially in compliance
  1409. 'with JPEG rules.  Components are interleaved whenever possible to emit as few scans as possible.
  1410.  
  1411.     Dim f            As Long       'First Index
  1412.     Dim g            As Long       'Second Index
  1413.     Dim Nb           As Long       'Number of 8X8 blocks in MCU
  1414.     Const MaxNb      As Long = 10  'Max 8X8 blocks in MCU  (10 for JPEG compliance)
  1415.     Dim flag         As Boolean    'True when ready to insert scan(s)
  1416.  
  1417.     f = FirstIndex
  1418.     g = FirstIndex
  1419.     Nb = 0
  1420.     flag = False
  1421.     While f <= SecondIndex
  1422.  
  1423.         Nb = Nb + Comp(CompIndex(g)).Hi * Comp(CompIndex(g)).Vi
  1424.         g = g + 1
  1425.  
  1426.         If Nb > MaxNb Then
  1427.             flag = True
  1428.             If f <> g - 1 Then g = g - 1
  1429.         Else
  1430.             If (g - f) = 3 Or g > SecondIndex Then flag = True
  1431.         End If
  1432.  
  1433.         If flag Then
  1434.             If f = g - 1 Then
  1435.                 InsertSOSNonInterleaved CompIndex(f), Td(f), Ta(f)
  1436.             Else
  1437.                 InsertSOSInterleaved CompIndex, Td, Ta, f, g - 1
  1438.             End If
  1439.             Nb = 0
  1440.             f = g
  1441.             flag = False
  1442.         End If
  1443.     Wend
  1444.  
  1445. End Sub
  1446.  
  1447.  
  1448.  
  1449.  
  1450.  
  1451. '========================================================================================
  1452. '                               W R I T I N G   F I L E
  1453. '========================================================================================
  1454. Private Function OptimizeHuffmanTables(CompIndex() As Long, Td() As Long, Ta() As Long, FirstIndex As Long, SecondIndex As Long) As Long
  1455. 'Optimize Huffman tables for the component indexes given.
  1456. 'Returns an estimate of the number of bytes needed for entropy coded data.
  1457. 'Estimate assumes a single scan, and entropy coded FF bytes are not followed by a zero stuff byte.
  1458.  
  1459.     Dim f            As Long      'First Index
  1460.     Dim g            As Long      'Second Index
  1461.     Dim i            As Long
  1462.     Dim j            As Long
  1463.     Dim k            As Long      'Total bytes required for entropy coded data
  1464.     Dim k1           As Long
  1465.     Dim k2           As Long
  1466.     Dim Nb           As Long      'Number of 8X8 blocks in MCU
  1467.     Const MaxNb      As Long = 10 'Max 8X8 blocks in MCU  (10 for JPEG compliance)
  1468.     Dim freq(256)    As Long      'frequency count for optimizing Huffman tables
  1469.     Dim freq2()      As Long      'copy of freq, used for calcultating entropy coded data size
  1470.     Dim IsInter()    As Boolean   'True if component i will be interleaved
  1471.     Dim TdUsed()     As Boolean   'True if HuffDC(i) is used
  1472.     Dim TaUsed()     As Boolean   'True if HuffAC(i) is used
  1473.     Dim flag         As Boolean   'True when ready to include scan(s)
  1474.  
  1475.     ReDim IsInter(FirstIndex To SecondIndex)
  1476.     ReDim TaUsed(3)
  1477.     ReDim TdUsed(3)
  1478.  
  1479.  
  1480.    'Determine which components will be interleaved by InsertSequentialScans(), which tables are used
  1481.     f = FirstIndex
  1482.     g = FirstIndex
  1483.     Nb = 0
  1484.     flag = False
  1485.     While f <= SecondIndex
  1486.  
  1487.         Nb = Nb + Comp(CompIndex(g)).Hi * Comp(CompIndex(g)).Vi
  1488.         g = g + 1
  1489.  
  1490.         If Nb > MaxNb Then
  1491.             flag = True
  1492.             If f <> g - 1 Then g = g - 1
  1493.         Else
  1494.             If (g - f) = 3 Or g > SecondIndex Then flag = True
  1495.         End If
  1496.  
  1497.         If flag Then
  1498.             If f = g - 1 Then
  1499.                     TdUsed(Td(f)) = True
  1500.                     TaUsed(Ta(f)) = True
  1501.                     IsInter(f) = False
  1502.             Else
  1503.                 For i = f To g - 1
  1504.                     TdUsed(Td(i)) = True
  1505.                     TaUsed(Ta(i)) = True
  1506.                     IsInter(i) = True
  1507.                 Next i
  1508.             End If
  1509.             Nb = 0
  1510.             f = g
  1511.             flag = False
  1512.         End If
  1513.     Wend
  1514.  
  1515.  
  1516.    'Optimize huffman tables for the scan sequence
  1517.     For i = 0 To 3
  1518.         If TdUsed(i) Then
  1519.             For f = FirstIndex To SecondIndex
  1520.                 With Comp(CompIndex(f))
  1521.                     If Td(f) = i Then
  1522.                         If IsInter(f) Then
  1523.                             CollectStatisticsDCInterleaved .Data, freq, .Hi, .Vi
  1524.                         Else
  1525.                             CollectStatisticsDCNonInterleaved .Data, freq
  1526.                         End If
  1527.                     End If
  1528.                 End With
  1529.             Next f
  1530.  
  1531.            'Optimize and create this DC table
  1532.             'freq2 = freq
  1533.             ReDim freq2(0 To 256)
  1534.             CopyMemory freq2(0), freq(0), 1024
  1535.             OptimizeHuffman HuffDC(i), freq
  1536.             ExpandHuffman HuffDC(i), IIf(PP = 12, 15, 11)
  1537.  
  1538.            'Calculate compressed data size and add to total k
  1539.             For j = 0 To 15
  1540.                 If freq2(j) <> 0 Then
  1541.                     k1 = j + Int(Log(HuffDC(i).EHUFSI(j)) * 1.442695040889) + 1 'Length of size category, in bits
  1542.                     k2 = k2 + freq2(j) * k1                                     'Sum all occurances of this coefficient, in bits
  1543.                     k = k + k2 \ 8                                              'add to byte count
  1544.                     k2 = k2 Mod 8                                               'preserve remaining bits
  1545.                 End If
  1546.             Next j
  1547.  
  1548.         End If
  1549.         If TaUsed(i) Then
  1550.             For f = FirstIndex To SecondIndex
  1551.                 If Td(f) = i Then CollectStatisticsAC Comp(CompIndex(f)).Data, freq
  1552.             Next f
  1553.  
  1554.            'Optimize and create this AC table
  1555.             'freq2 = freq
  1556.             ReDim freq2(0 To 256)
  1557.             CopyMemory freq2(0), freq(0), 1024
  1558.             OptimizeHuffman HuffAC(i), freq
  1559.             ExpandHuffman HuffAC(i), 255
  1560.  
  1561.            'Calculate compressed data size and add to total k
  1562.             For j = 0 To 255
  1563.                 If freq2(j) <> 0 Then
  1564.                     k1 = (j And 15) + Int(Log(HuffAC(i).EHUFSI(j)) * 1.442695040889) + 1 'Length of size category, in bits
  1565.                     k2 = k2 + freq2(j) * k1                                              'Sum all occurances of this coefficient, in bits
  1566.                     k = k + k2 \ 8                                                       'add to byte count
  1567.                     k2 = k2 Mod 8                                                        'preserve remaining bits
  1568.                 End If
  1569.             Next j
  1570.  
  1571.         End If
  1572.     Next i
  1573.  
  1574.     If (k2 Mod 8) <> 0 Then k = k + 1
  1575.     OptimizeHuffmanTables = k
  1576.  
  1577. End Function
  1578.  
  1579.  
  1580.  
  1581. Friend Function SaveFile(FileName As String) As Long
  1582.     Dim CompIndex()  As Long 'Indexes of Components to be included
  1583.     Dim Td()         As Long 'DC Huffman Table Selectors
  1584.     Dim Ta()         As Long 'AC Huffman Table Selectors
  1585.     Dim FileNum      As Integer
  1586.     Dim i            As Long
  1587.  
  1588.  
  1589.     If Len(FileName) = 0 Then
  1590.         SaveFile = 1         'FileName not given
  1591.     Else
  1592.         If (Len(Dir(FileName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive)) > 0) Then
  1593.             SaveFile = 2     'File already exists
  1594.         Else
  1595.  
  1596.  
  1597.     ReDim CompIndex(Nf - 1)
  1598.     ReDim Td(Nf - 1)
  1599.     ReDim Ta(Nf - 1)
  1600.  
  1601.     For i = 0 To Nf - 1
  1602.         CompIndex(i) = i
  1603.         Td(i) = IIf(i = 0, 0, 1)
  1604.         Ta(i) = IIf(i = 0, 0, 1)
  1605.     Next i
  1606.  
  1607.     i = OptimizeHuffmanTables(CompIndex, Td, Ta, 0, Nf - 1)
  1608.  
  1609.    'Estimate maximum possible file size needed
  1610.     i = 1.3 * i + 1000 + Len(m_Comment)
  1611.     ReDim m_Data(i)
  1612.     m_Ptr = 0
  1613.  
  1614.     InsertMarker SOI                                   'SOI - Start of Image
  1615.     InsertJFIF                                         'JFIF
  1616.  
  1617.     If Len(m_Comment) > 0 Then InsertCOM m_Comment     'COM - Comment
  1618.     'InsertCOM "JPEG Encoder Class" & vbCrLf & "Written by John Korejwa <korejwa@tiac.net>" & vbCrLf & "Visual Basic sourcecode available at planetsourcecode.com"
  1619.  
  1620.     InsertDQT m_Ptr, 0                                 'DQT - Define Quantization Tables
  1621.     If Nf > 1 Then InsertDQT m_Ptr, 1
  1622.  
  1623.     InsertSOF SOF0                                     'SOF - Start of Frame
  1624.  
  1625.     InsertDHT m_Ptr, 0, False                          'DHT - Define Huffman Tables
  1626.     InsertDHT m_Ptr, 0, True
  1627.     If Nf > 1 Then
  1628.         InsertDHT m_Ptr, 1, False
  1629.         InsertDHT m_Ptr, 1, True
  1630.     End If
  1631.  
  1632.     InsertSequentialScans CompIndex, Td, Ta, 0, Nf - 1 'SOS - Scan Data
  1633.     InsertMarker EOI                                   'EOI - End of Image
  1634.  
  1635.    'Size the final byte array and write to file
  1636.     ReDim Preserve m_Data(m_Ptr - 1)
  1637.     FileNum = FreeFile
  1638.     Open FileName For Binary Access Write As FileNum
  1639.         Put #FileNum, , m_Data
  1640.     Close FileNum
  1641.     Erase m_Data
  1642.  
  1643.  
  1644.         End If
  1645.     End If
  1646.  
  1647. End Function
  1648.  
  1649.  
  1650.  
  1651.  
  1652. '========================================================================================
  1653. '                         C L A S S   I N I T I A L I Z A T I O N
  1654. '========================================================================================
  1655. Private Sub Class_Initialize()
  1656.     Dim i As Long
  1657.     Dim j As Long
  1658.     Dim dx As Long
  1659.     Dim zz As Long
  1660.  
  1661.     i = 0                   'Initialize the ZigZag() array, which maps out the
  1662.     j = 0                   '  zig-zag sequence of quantized DCT coefficients
  1663.     dx = 1                  '  in approximately low to high spatial frequencies
  1664.     For zz = 0 To 63
  1665.         ZigZag(i, j) = zz
  1666.         i = i + dx
  1667.         j = j - dx
  1668.         If i > 7 Then              '  0   1   5   6  14  15  27  28
  1669.             i = 7                  '  2   4   7  13  16  26  29  42
  1670.             j = j + 2              '  3   8  12  17  25  30  41  43
  1671.             dx = -1                '  9  11  18  24  31  40  44  53
  1672.         ElseIf j > 7 Then          ' 10  19  23  32  39  45  52  54
  1673.             j = 7                  ' 20  22  33  38  46  51  55  60
  1674.             i = i + 2              ' 21  34  37  47  50  56  59  61
  1675.             dx = 1                 ' 35  36  48  49  57  58  62  63
  1676.         ElseIf i < 0 Then
  1677.             i = 0 'check (j>7) first
  1678.             dx = 1
  1679.         ElseIf j < 0 Then
  1680.             j = 0
  1681.             dx = -1
  1682.         End If
  1683.     Next zz
  1684.  
  1685.    'Luminance Quantization table for Quality = 50
  1686.     QLumin(0) = 16:   QLumin(1) = 11:   QLumin(2) = 12:   QLumin(3) = 14
  1687.     QLumin(4) = 12:   QLumin(5) = 10:   QLumin(6) = 16:   QLumin(7) = 14
  1688.     QLumin(8) = 13:   QLumin(9) = 14:   QLumin(10) = 18:  QLumin(11) = 17
  1689.     QLumin(12) = 16:  QLumin(13) = 19:  QLumin(14) = 24:  QLumin(15) = 40
  1690.     QLumin(16) = 26:  QLumin(17) = 24:  QLumin(18) = 22:  QLumin(19) = 22
  1691.     QLumin(20) = 24:  QLumin(21) = 49:  QLumin(22) = 35:  QLumin(23) = 37
  1692.     QLumin(24) = 29:  QLumin(25) = 40:  QLumin(26) = 58:  QLumin(27) = 51
  1693.     QLumin(28) = 61:  QLumin(29) = 60:  QLumin(30) = 57:  QLumin(31) = 51
  1694.     QLumin(32) = 56:  QLumin(33) = 55:  QLumin(34) = 64:  QLumin(35) = 72
  1695.     QLumin(36) = 92:  QLumin(37) = 78:  QLumin(38) = 64:  QLumin(39) = 68
  1696.     QLumin(40) = 87:  QLumin(41) = 69:  QLumin(42) = 55:  QLumin(43) = 56
  1697.     QLumin(44) = 80:  QLumin(45) = 109: QLumin(46) = 81:  QLumin(47) = 87
  1698.     QLumin(48) = 95:  QLumin(49) = 98:  QLumin(50) = 103: QLumin(51) = 104
  1699.     QLumin(52) = 103: QLumin(53) = 62:  QLumin(54) = 77:  QLumin(55) = 113
  1700.     QLumin(56) = 121: QLumin(57) = 112: QLumin(58) = 100: QLumin(59) = 120
  1701.     QLumin(60) = 92:  QLumin(61) = 101: QLumin(62) = 103: QLumin(63) = 99
  1702.  
  1703.    'Chrominance Quantization table for Quality = 50
  1704.     QChrom(0) = 17:   QChrom(1) = 18:   QChrom(2) = 18:   QChrom(3) = 24
  1705.     QChrom(4) = 21:   QChrom(5) = 24:   QChrom(6) = 47:   QChrom(7) = 26
  1706.     QChrom(8) = 26:   QChrom(9) = 47:   QChrom(10) = 99:  QChrom(11) = 66
  1707.     QChrom(12) = 56:  QChrom(13) = 66:  QChrom(14) = 99:  QChrom(15) = 99
  1708.     QChrom(16) = 99:  QChrom(17) = 99:  QChrom(18) = 99:  QChrom(19) = 99
  1709.     QChrom(20) = 99:  QChrom(21) = 99:  QChrom(22) = 99:  QChrom(23) = 99
  1710.     QChrom(24) = 99:  QChrom(25) = 99:  QChrom(26) = 99:  QChrom(27) = 99
  1711.     QChrom(28) = 99:  QChrom(29) = 99:  QChrom(30) = 99:  QChrom(31) = 99
  1712.     QChrom(32) = 99:  QChrom(33) = 99:  QChrom(34) = 99:  QChrom(35) = 99
  1713.     QChrom(36) = 99:  QChrom(37) = 99:  QChrom(38) = 99:  QChrom(39) = 99
  1714.     QChrom(40) = 99:  QChrom(41) = 99:  QChrom(42) = 99:  QChrom(43) = 99
  1715.     QChrom(44) = 99:  QChrom(45) = 99:  QChrom(46) = 99:  QChrom(47) = 99
  1716.     QChrom(48) = 99:  QChrom(49) = 99:  QChrom(50) = 99:  QChrom(51) = 99
  1717.     QChrom(52) = 99:  QChrom(53) = 99:  QChrom(54) = 99:  QChrom(55) = 99
  1718.     QChrom(56) = 99:  QChrom(57) = 99:  QChrom(58) = 99:  QChrom(59) = 99
  1719.     QChrom(60) = 99:  QChrom(61) = 99:  QChrom(62) = 99:  QChrom(63) = 99
  1720.  
  1721.  
  1722.     FDCTScale(0) = 0.353553390593273     '0.25 / Cos(4 / 16 * PI)
  1723.     FDCTScale(1) = 0.25489778955208      '0.25 / Cos(1 / 16 * PI)
  1724.     FDCTScale(2) = 0.270598050073098     '0.25 / Cos(2 / 16 * PI)
  1725.     FDCTScale(3) = 0.300672443467523     '0.25 / Cos(3 / 16 * PI)
  1726.     FDCTScale(4) = 0.353553390593273     '0.25 / Cos(4 / 16 * PI)
  1727.     FDCTScale(5) = 0.449988111568207     '0.25 / Cos(5 / 16 * PI)
  1728.     FDCTScale(6) = 0.653281482438186     '0.25 / Cos(6 / 16 * PI)
  1729.     FDCTScale(7) = 1.28145772387074      '0.25 / Cos(7 / 16 * PI)
  1730.  
  1731.     SetSamplingFrequencies 2, 2, 1, 1, 1, 1
  1732.     Quality = 75
  1733.  
  1734. End Sub
  1735.  
  1736. 'ADDED BY SCINER - lenar2003@mail.ru
  1737. '30/10/2004 5:00
  1738. Public Function SaveToJpeg(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal JpegFile As String, Optional ByVal JpegQuality As Long = 20, Optional ByVal Progressive As Boolean = True, Optional ByVal GrayScale As Boolean = False, Optional ByVal CommentText As String = "SCINSpy - Created by SCINER: lenar2003@mail.ru") As Boolean
  1739.   'Returns: True = Success
  1740.  
  1741.   Dim Ret As Long
  1742.   
  1743.   Me.Comment = CommentText
  1744.   Me.Quality = JpegQuality
  1745.  
  1746.   If GrayScale Then
  1747.     If Progressive Then
  1748.       Me.SetSamplingFrequencies 4, 4, 0, 0, 0, 0
  1749.     Else
  1750.       Me.SetSamplingFrequencies 1, 1, 0, 0, 0, 0
  1751.     End If
  1752.   Else
  1753.     If Progressive Then
  1754.       Me.SetSamplingFrequencies 4, 4, 1, 1, 1, 1
  1755.     Else
  1756.       Me.SetSamplingFrequencies 1, 1, 1, 1, 1, 1
  1757.     End If
  1758.   End If
  1759.  
  1760.   Ret = Me.SampleHDC(hdc, Width, Height, x, y)
  1761.   
  1762.   If Ret = 0 Then Me.SaveFile JpegFile
  1763.   SaveToJpeg = Ret = 0
  1764.   
  1765.   End Function

Ответить

Страница: 1 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам