home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / EGL_PngTga2141561262009.psc / clsLoadPNG.cls < prev    next >
Text File  |  2009-01-22  |  33KB  |  881 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 = "clsLoadPNG"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' Original Code : CodeId=56537 (PNG Class By Alfred Koppold)
  15. ' Revision By Erkan ▐anl² 2009
  16. Option Explicit
  17.  
  18. Private Type HEADER '13 Byte
  19.     Width               As Long     '4
  20.     Height              As Long     '4
  21.     Bitdepht            As Byte     '1
  22.     ColorType           As Byte     '1
  23.     Compression         As Byte     '1
  24.     Filter              As Byte     '1
  25.     Interlacing         As Byte     '1
  26. End Type
  27.  
  28. Private mHeader         As HEADER
  29. Private mWidth          As Long
  30. Private mHeight         As Long
  31. Private mBitmapData()   As Byte
  32.   
  33. Private mTrans          As Boolean
  34. Private mTransData()    As Byte
  35. Private mBPP            As Byte
  36.  
  37. Public Sub LoadPNG(Filename As String)
  38.     
  39.     Dim Filenumber      As Long
  40.     Dim LenIDAT         As Long
  41.     Dim ChunkSize       As Long
  42.     Dim ChunkType       As String * 4
  43.     Dim Seeker          As Long
  44.     Dim Signature(1)    As Long
  45.     Dim IDATData()      As Byte
  46.     Dim Buffer()        As Byte
  47.     Dim CRC32           As Long
  48.     Dim DataSize        As Long
  49.  
  50. 'Reset data
  51.     LenIDAT = 0
  52.     ReDim IDATData(LenIDAT)
  53. 'Open file
  54.     Filenumber = FreeFile
  55.     Open Filename For Binary As Filenumber
  56. 'Check signature
  57.         Get Filenumber, , Signature
  58.         If Signature(0) <> &H474E5089 Or Signature(1) <> &HA1A0A0D Then Exit Sub
  59.         Do
  60. 'Read chunk
  61.             Get Filenumber, , ChunkSize
  62.             Get Filenumber, , ChunkType
  63.             Call Swap4Bytes(ChunkSize)
  64.             If ChunkSize > 0 Then ReDim Buffer(ChunkSize - 1)
  65. 'Check EOF
  66.             Seeker = Seek(Filenumber)
  67.             If Seeker + ChunkSize > LOF(Filenumber) Then Exit Sub
  68. 'Read Buffer
  69.             Get Filenumber, , Buffer
  70.             Get Filenumber, , CRC32
  71.             Select Case ChunkType
  72.                 Case "IHDR"
  73.                     With mHeader
  74.                         CopyMemory .Width, Buffer(0), 4:  Call Swap4Bytes(.Width)
  75.                         CopyMemory .Height, Buffer(4), 4: Call Swap4Bytes(.Height)
  76.                         .Bitdepht = Buffer(8)
  77.                         .ColorType = Buffer(9)
  78.                         .Compression = Buffer(10)
  79.                         .Filter = Buffer(11)
  80.                         .Interlacing = Buffer(12)
  81.                     End With
  82.                 Case "PLTE"
  83.                     mColorPalette = Buffer
  84.                 Case "IDAT"
  85.                     ReDim Preserve IDATData(LenIDAT + UBound(Buffer))
  86.                     CopyMemory IDATData(LenIDAT), Buffer(0), UBound(Buffer) + 1
  87.                     LenIDAT = UBound(IDATData) + 1
  88.                 Case "IEND"
  89.                     Exit Do
  90.                 Case "tRNS"
  91.                     mTrans = True
  92.                     mTransData = Buffer
  93.             End Select
  94.         Loop
  95.         If LenIDAT = 0 Then Exit Sub
  96.     Close Filenumber
  97.     Erase Buffer
  98. 'Copy IDAT to mBitmapData and set mWidth and mHeight
  99.     mWidth = mHeader.Width
  100.     mHeight = mHeader.Height
  101.     ReDim mBitmapData(UBound(IDATData) - 2)
  102.     CopyMemory mBitmapData(0), IDATData(2), UBound(IDATData) - 1
  103.     Erase IDATData
  104. 'Decompress
  105.     If mHeader.Compression = 0 Then
  106.         DataSize = mHeight * DataPerRowBytes
  107.         If mHeader.Interlacing Then DataSize = DataSize + mHeight
  108.         Call DecompLZ77(DataSize, mBitmapData)
  109.     End If
  110. 'Defilter
  111.     If mHeader.Interlacing Then
  112.         Call DeFilterInterlaced
  113.     Else
  114.         Call DeFilter
  115.     End If
  116. 'Process
  117.     Call DataProcess
  118.     Call DrawBitmap(mWidth, mHeight)
  119.  
  120. End Sub
  121.  
  122. Private Sub DataProcess()
  123.  
  124.     With mHeader
  125. 'Create Bitmap
  126.         Select Case .ColorType
  127.             
  128.             Case ct_GRAY
  129.                 Select Case .Bitdepht
  130.                     
  131.                     Case bd_01
  132.                         If .Interlacing Then
  133.                             Call CreateTable(ct_GRAY, bd_01, True)
  134.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  135.                         Else
  136.                             Call CreateTable(ct_GRAY, bd_01)
  137.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_01, True)
  138.                         End If
  139.                     
  140.                     Case bd_02
  141.                         If .Interlacing = 0 Then _
  142.                         Call BitsToBytes(2, (UBound(mBitmapData) + 1) * 4, mBitmapData) ' 2 >> 8
  143.                         Call CreateTable(ct_GRAY, bd_02)
  144.                         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  145.                     
  146.                     Case bd_04
  147.                         If .Interlacing Then
  148.                             Call CreateTable(ct_GRAY, bd_04, True)
  149.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  150.                         Else
  151.                             Call Align32(bd_04)
  152.                             Call CreateTable(ct_GRAY, bd_04)
  153.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_04, True)
  154.                         End If
  155.                     
  156.                     Case bd_08
  157.                         Call Align32(bd_08)
  158.                         Call CreateTable(ct_GRAY, bd_08)
  159.                         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  160.                     
  161.                     Case bd_16
  162.                         Call Conv16To8 '16 >> 8
  163.                         Call CreateTable(ct_GRAY, bd_08)
  164.                         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  165.                 End Select
  166.                 
  167.             Case ct_RGB
  168.                 If .Bitdepht = bd_16 Then Call Conv16To8
  169.                 Call SwapRGB
  170.                 mBPP = bd_08
  171.                 Call Align32(bd_24)
  172.                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_24, True)
  173.             
  174.             Case ct_PAL
  175.                 Select Case .Bitdepht
  176.                     
  177.                     Case bd_01
  178.                         If .Interlacing Then
  179.                             Call CreateTable(ct_PAL, bd_08)
  180.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  181.                         Else
  182.                             Call CreateTable(ct_PAL, bd_01)
  183.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_01, True)
  184.                         End If
  185.                     
  186.                     Case bd_02
  187.                         If .Interlacing Then
  188.                             mBPP = bd_08
  189.                             Call Align32(bd_08)
  190.                         Else
  191.                             Call BitsToBytes(2, (UBound(mBitmapData) + 1) * 4, mBitmapData) ' 2 >> 8
  192.                         End If
  193.                         Call CreateTable(ct_PAL, bd_08)
  194.                         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  195.                     
  196.                     Case bd_04
  197.                         If .Interlacing Then
  198.                             mBPP = bd_08
  199.                             Call Align32(bd_08)
  200.                             Call CreateTable(ct_PAL, bd_08)
  201.                             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  202.                         Else
  203.                             Call Align32(bd_04)
  204.                             If mTrans Then
  205.                                 Call PalToRGBA(bd_04)
  206.                                 Call MakeAlpha(mWidth, mHeight, mBitmapData, True)
  207.                                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_24, True)
  208.                             Else
  209.                                 Call CreateTable(ct_PAL, bd_04)
  210.                                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_04, True)
  211.                             End If
  212.                         End If
  213.                     
  214.                     Case bd_08
  215.                             Call Align32(bd_08)
  216.                             If mTrans Then
  217.                                 Call PalToRGBA(bd_08)
  218.                                 Call MakeAlpha(mWidth, mHeight, mBitmapData, True)
  219.                                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_24, True)
  220.                             Else
  221.                                 Call CreateTable(ct_PAL, bd_08)
  222.                                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08, True)
  223.                             End If
  224.                 End Select
  225.             
  226.             Case ct_GRAYA
  227.                 If .Bitdepht = bd_16 Then Call Conv16To8
  228.                 Call GrayAToRGBA
  229.                 Call MakeAlpha(mWidth, mHeight, mBitmapData, True)
  230.                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_24, True)
  231.             
  232.             Case ct_RGBA
  233.                 If .Bitdepht = bd_16 Then Call Conv16To8
  234.                 Call SwapRGBA
  235.                 Call MakeAlpha(mWidth, mHeight, mBitmapData, True)
  236.                 Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_24, True)
  237.                 
  238.         End Select
  239.     End With
  240.     
  241. End Sub
  242.  
  243. Private Function DataPerRowBytes() As Long
  244.     
  245.     DataPerRowBytes = (mWidth * BitsPerPixel + 7) \ 8 + 1
  246.  
  247. End Function
  248.  
  249. Private Function RowBytes(Depth As BIT_DEPTH) As Long
  250.     
  251.     RowBytes = ((mWidth * Depth + 31) \ 32) * 4
  252.  
  253. End Function
  254.  
  255. Private Function BitsPerPixel() As Long
  256.     
  257.     Dim Bpp As Long
  258.  
  259.     If mBPP <> mHeader.Bitdepht And mBPP <> 0 Then
  260.         Bpp = mBPP
  261.     Else
  262.         Bpp = mHeader.Bitdepht
  263.     End If
  264.     
  265.     Select Case mHeader.ColorType
  266.         Case 0: BitsPerPixel = Bpp      'Grayscale
  267.         Case 2: BitsPerPixel = Bpp * 3  'RGB
  268.         Case 3: BitsPerPixel = Bpp      'Palette
  269.         Case 4: BitsPerPixel = Bpp * 2  'Grayscale + Alpha
  270.         Case 6: BitsPerPixel = Bpp * 4  'RGB + Alpha
  271.     End Select
  272.     
  273. End Function
  274.  
  275. Private Sub Conv16To8()
  276.     
  277.     Dim DstOff      As Long
  278.     Dim DstBuffer() As Byte
  279.     Dim idx         As Long
  280.     
  281.     ReDim DstBuffer(UBound(mBitmapData) \ 2)
  282.     For idx = 0 To UBound(mBitmapData) Step 2
  283.         DstBuffer(DstOff) = mBitmapData(idx)
  284.         DstOff = DstOff + 1
  285.     Next idx
  286.     mBitmapData = DstBuffer
  287.  
  288. End Sub
  289.  
  290. Private Sub Align32(Depth As BIT_DEPTH)
  291.  
  292.     Dim DstRowBytes As Long
  293.     Dim SrcRowBytes As Long
  294.     Dim DstOff      As Long
  295.     Dim SrcOff      As Long
  296.     Dim DstBuffer() As Byte
  297.     Dim idx         As Long
  298.        
  299.     DstRowBytes = RowBytes(Depth)
  300.     SrcRowBytes = DataPerRowBytes - 1
  301.     
  302.     If mHeader.ColorType = ct_GRAYA Then SrcRowBytes = SrcRowBytes / 2
  303.     If DstRowBytes <> SrcRowBytes Then
  304.         ReDim DstBuffer(DstRowBytes * mHeight - 1)
  305.         For idx = 0 To mHeight - 1
  306.             DstOff = DstRowBytes * idx
  307.             SrcOff = SrcRowBytes * idx
  308.             Call CopyMemory(DstBuffer(DstOff), mBitmapData(SrcOff), SrcRowBytes)
  309.         Next idx
  310.         mBitmapData = DstBuffer
  311.     End If
  312.     
  313. End Sub
  314.  
  315. Private Sub GrayAToRGBA()
  316.  
  317.     Dim DstOff      As Long
  318.     Dim DstBuffer() As Byte
  319.     Dim idx         As Long
  320.  
  321.     ReDim DstBuffer((UBound(mBitmapData) + 1) * 2 - 1)
  322.     For idx = 0 To UBound(mBitmapData) Step 2
  323.         DstBuffer(DstOff) = mBitmapData(idx)
  324.         DstBuffer(DstOff + 1) = mBitmapData(idx)
  325.         DstBuffer(DstOff + 2) = mBitmapData(idx)
  326.         DstBuffer(DstOff + 3) = mBitmapData(idx + 1)
  327.         DstOff = DstOff + 4
  328.     Next idx
  329.     mBitmapData = DstBuffer
  330.  
  331. End Sub
  332.  
  333. Private Sub PalToRGBA(Depth As BIT_DEPTH)
  334.  
  335.      Dim DestBuffer()   As Byte
  336.      Dim n              As Long
  337.      Dim PalEntry       As Byte
  338.      Dim DestOff        As Long
  339.      Dim TrnsBnd        As Long
  340.      Dim X              As Long
  341.      Dim Y              As Long
  342.      Dim WidthBytes     As Long
  343.      Dim Pal()          As RGBTRIPLE
  344.      
  345.      With mHeader
  346.         ReDim DestBuffer(4 * .Width * .Height - 1)
  347.         TrnsBnd = UBound(mTransData)
  348.         WidthBytes = RowBytes(Depth)
  349.         ReDim Pal((UBound(mColorPalette) \ 3))
  350.         CopyMemory Pal(0), mColorPalette(0), UBound(mColorPalette) + 1
  351.         Select Case Depth
  352.             Case 8
  353.                 For Y = 0 To .Height - 1
  354.                     For X = 0 To .Width - 1
  355.                         n = Y * WidthBytes + X
  356.                         PalEntry = mBitmapData(n)
  357.                         With Pal(PalEntry)
  358.                             DestBuffer(DestOff) = .Blue
  359.                             DestBuffer(DestOff + 1) = .Green
  360.                             DestBuffer(DestOff + 2) = .Red
  361.                         End With
  362.                         If PalEntry <= TrnsBnd Then
  363.                             DestBuffer(DestOff + 3) = mTransData(PalEntry)
  364.                         Else
  365.                             DestBuffer(DestOff + 3) = 255
  366.                         End If
  367.                         DestOff = DestOff + 4
  368.                     Next X
  369.                 Next Y
  370.             Case 4
  371.                 For Y = 0 To .Height - 1
  372.                     For X = 0 To .Width - 1
  373.                         n = Y * WidthBytes + X \ 2
  374.                         If (X Mod 2) = 1 Then
  375.                             PalEntry = mBitmapData(n) And 15
  376.                         Else
  377.                             PalEntry = (mBitmapData(n) \ 16) And 15
  378.                         End If
  379.                         With Pal(PalEntry)
  380.                             DestBuffer(DestOff) = .Blue
  381.                             DestBuffer(DestOff + 1) = .Green
  382.                             DestBuffer(DestOff + 2) = .Red
  383.                         End With
  384.                         If PalEntry <= TrnsBnd Then
  385.                             DestBuffer(DestOff + 3) = mTransData(PalEntry)
  386.                         Else
  387.                             DestBuffer(DestOff + 3) = 255
  388.                         End If
  389.                         DestOff = DestOff + 4
  390.                     Next X
  391.                 Next Y
  392.             Case 1
  393.                 For Y = 0 To .Height - 1
  394.                     For X = 0 To .Width - 1
  395.                         n = Y * WidthBytes + X \ 8
  396.                         If (X Mod 8) <> 7 Then
  397.                             PalEntry = (mBitmapData(n) \ 2 ^ (7 - X Mod 8)) And 1
  398.                         Else
  399.                             PalEntry = mBitmapData(n) And 1
  400.                         End If
  401.                         With Pal(PalEntry)
  402.                             DestBuffer(DestOff) = .Blue
  403.                             DestBuffer(DestOff + 1) = .Green
  404.                             DestBuffer(DestOff + 2) = .Red
  405.                         End With
  406.                         If PalEntry <= TrnsBnd Then
  407.                             DestBuffer(DestOff + 3) = mTransData(PalEntry)
  408.                         Else
  409.                             DestBuffer(DestOff + 3) = 255
  410.                         End If
  411.                         DestOff = DestOff + 4
  412.                     Next X
  413.                 Next Y
  414.         End Select
  415.     End With
  416.     mBitmapData = DestBuffer
  417.     
  418. End Sub
  419.  
  420. Private Sub DeFilter()
  421.     
  422.     Dim SrcOff          As Long
  423.     Dim DstOff          As Long
  424.     Dim DstBuffer()     As Byte
  425.     Dim idx             As Long
  426.     Dim Interval        As Long
  427.     Dim CurRowBytes()   As Byte 'Current
  428.     Dim PrvRowBytes()   As Byte 'Previous
  429.     Dim DataPRow        As Long
  430.     
  431.     DataPRow = DataPerRowBytes
  432.     ReDim DstBuffer(UBound(mBitmapData) - mHeight)
  433.     ReDim PrvRowBytes(DataPRow - 2)
  434.     ReDim CurRowBytes(DataPRow - 2)
  435.     
  436.     Interval = Abs(BitsPerPixel / 8)
  437.     If Interval = 0 Then Interval = 1
  438.     
  439.     For idx = 0 To mHeight - 1
  440.         SrcOff = DataPRow * idx
  441.         DstOff = SrcOff - idx
  442.         Call CopyMemory(CurRowBytes(0), mBitmapData(SrcOff + 1), DataPRow - 1)
  443.         Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(SrcOff), Interval)
  444.         Call CopyMemory(DstBuffer(DstOff), CurRowBytes(0), DataPRow - 1)
  445.     Next idx
  446.     mBitmapData = DstBuffer
  447.  
  448. End Sub
  449.  
  450. Private Sub DeFilterInterlaced()
  451.     
  452.     Dim Bpp             As Long
  453.     Dim DstBuffer()     As Byte
  454.     Dim CurRowBytes()   As Byte
  455.     Dim PrvRowBytes()   As Byte
  456.     Dim StdBuffer       As Long
  457.     Dim Interval        As Long
  458.     Dim Rest8           As Long
  459.     Dim Height8         As Long
  460.     Dim State           As String
  461.     Dim ZL              As Long
  462.     Dim MengeRow        As Long
  463.     Dim idx             As Long
  464.     Dim Nr              As Long
  465.     Dim ZZ              As Long
  466.     Dim ZLBytes         As Long
  467.     
  468.     Bpp = BitsPerPixel
  469.     Interval = IIf(Bpp >= 8, Abs(Bpp / 8), 1)
  470.  
  471.     With mHeader
  472.         ReDim DstBuffer((.Width * .Height * Interval) - 1)
  473.         Rest8 = .Height Mod 8
  474.         Height8 = (.Height - Rest8) / 8
  475.         
  476.         State = "1"
  477.         ZL = BerechneRowLen(Bpp, State)
  478.         If ZL > 0 Then
  479.             ReDim PrvRowBytes(ZL - 1)
  480.             MengeRow = Height8
  481.             If Rest8 > 0 Then MengeRow = MengeRow + 1
  482.             For idx = 1 To MengeRow
  483.                 ReDim CurRowBytes(ZL - 1)
  484.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  485.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  486.                 StdBuffer = StdBuffer + ZL + 1
  487.                 If Bpp < 8 Then
  488.                     ZLBytes = BerechneRowLen(8, State)
  489.                 Else
  490.                     ZLBytes = 0
  491.                 End If
  492.                 PutBuffer DstBuffer, CurRowBytes, 1, 1, idx, ZLBytes
  493.             Next idx
  494.         End If
  495.         
  496.         State = "5"
  497.         ZL = BerechneRowLen(Bpp, State)
  498.         If ZL > 0 Then
  499.             ReDim PrvRowBytes(ZL - 1)
  500.             MengeRow = Height8
  501.             If Rest8 > 0 Then MengeRow = MengeRow + 1
  502.             For idx = 1 To MengeRow
  503.                 ReDim CurRowBytes(ZL - 1)
  504.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  505.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  506.                 StdBuffer = StdBuffer + ZL + 1
  507.                 If Bpp < 8 Then
  508.                     ZLBytes = BerechneRowLen(8, State)
  509.                 Else
  510.                     ZLBytes = 0
  511.                 End If
  512.                 PutBuffer DstBuffer, CurRowBytes, 2, 1, idx, ZLBytes
  513.             Next idx
  514.         End If
  515.  
  516.         State = "15"
  517.         ZL = BerechneRowLen(Bpp, State)
  518.         If ZL > 0 Then
  519.             ReDim PrvRowBytes(ZL - 1)
  520.             MengeRow = Height8
  521.             If Rest8 > 4 Then MengeRow = MengeRow + 1
  522.             For idx = 1 To MengeRow
  523.                 ReDim CurRowBytes(ZL - 1)
  524.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  525.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  526.                 StdBuffer = StdBuffer + ZL + 1
  527.                 If Bpp < 8 Then
  528.                     ZLBytes = BerechneRowLen(8, State)
  529.                 Else
  530.                     ZLBytes = 0
  531.                 End If
  532.                 PutBuffer DstBuffer, CurRowBytes, 3, 5, idx, ZLBytes
  533.             Next idx
  534.         End If
  535.     
  536.         State = "37"
  537.         ZZ = 1
  538.         ZL = BerechneRowLen(Bpp, State)
  539.         If ZL > 0 Then
  540.             ReDim PrvRowBytes(ZL - 1)
  541.             MengeRow = Height8 * 2
  542.             If Rest8 > 0 Then MengeRow = MengeRow + 1
  543.             If Rest8 > 4 Then MengeRow = MengeRow + 1
  544.             Nr = 1
  545.             For idx = 1 To MengeRow
  546.                 ReDim CurRowBytes(ZL - 1)
  547.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  548.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  549.                 StdBuffer = StdBuffer + ZL + 1
  550.                 If Bpp < 8 Then
  551.                     ZLBytes = BerechneRowLen(8, State)
  552.                 Else
  553.                     ZLBytes = 0
  554.                 End If
  555.                 PutBuffer DstBuffer, CurRowBytes, 4, Nr, ZZ, ZLBytes
  556.                 If Nr = 1 Then
  557.                     Nr = 5
  558.                 Else
  559.                     Nr = 1: ZZ = ZZ + 1
  560.                 End If
  561.             Next idx
  562.         End If
  563.         
  564.         State = "1357"
  565.         ZL = BerechneRowLen(Bpp, State)
  566.         If ZL > 0 Then
  567.             ReDim PrvRowBytes(ZL - 1)
  568.             MengeRow = Height8 * 2
  569.             If Rest8 > 2 Then MengeRow = MengeRow + 1
  570.             If Rest8 > 6 Then MengeRow = MengeRow + 1
  571.             ZZ = 1: Nr = 3
  572.             For idx = 1 To MengeRow
  573.                 ReDim CurRowBytes(ZL - 1)
  574.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  575.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  576.                 StdBuffer = StdBuffer + ZL + 1
  577.                 If Bpp < 8 Then
  578.                     ZLBytes = BerechneRowLen(8, State)
  579.                 Else
  580.                     ZLBytes = 0
  581.                 End If
  582.                 PutBuffer DstBuffer, CurRowBytes, 5, Nr, ZZ, ZLBytes
  583.                 Select Case Nr
  584.                     Case 3: Nr = 7
  585.                     Case 7: Nr = 3: ZZ = ZZ + 1
  586.                 End Select
  587.             Next idx
  588.         End If
  589.         
  590.         State = "2468"
  591.         ZL = BerechneRowLen(Bpp, State)
  592.         If ZL > 0 Then
  593.             ReDim PrvRowBytes(ZL - 1)
  594.             ZZ = 1: Nr = 1
  595.             MengeRow = Height8 * 4
  596.             If Rest8 > 0 Then MengeRow = MengeRow + 1
  597.             If Rest8 > 2 Then MengeRow = MengeRow + 1
  598.             If Rest8 > 4 Then MengeRow = MengeRow + 1
  599.             If Rest8 > 6 Then MengeRow = MengeRow + 1
  600.             For idx = 1 To MengeRow
  601.                 ReDim CurRowBytes(ZL - 1)
  602.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  603.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  604.                 StdBuffer = StdBuffer + ZL + 1
  605.                 If Bpp < 8 Then
  606.                     ZLBytes = BerechneRowLen(8, State)
  607.                 Else
  608.                     ZLBytes = 0
  609.                 End If
  610.                 PutBuffer DstBuffer, CurRowBytes, 6, Nr, ZZ, ZLBytes
  611.                 Select Case Nr
  612.                     Case 1: Nr = 3
  613.                     Case 3: Nr = 5
  614.                     Case 5: Nr = 7
  615.                     Case 7: Nr = 1: ZZ = ZZ + 1
  616.                 End Select
  617.             Next idx
  618.         End If
  619.  
  620.         State = "12345678"
  621.         ZL = BerechneRowLen(Bpp, State)
  622.         If ZL > 0 Then
  623.             ReDim PrvRowBytes(ZL - 1)
  624.             ZZ = 1: Nr = 2
  625.             MengeRow = Height8 * 4
  626.             If Rest8 > 1 Then MengeRow = MengeRow + 1
  627.             If Rest8 > 3 Then MengeRow = MengeRow + 1
  628.             If Rest8 > 5 Then MengeRow = MengeRow + 1
  629.             If Rest8 > 7 Then MengeRow = MengeRow + 1
  630.             For idx = 1 To MengeRow
  631.                 ReDim CurRowBytes(ZL - 1)
  632.                 CopyMemory CurRowBytes(0), mBitmapData(StdBuffer + 1), ZL
  633.                 Call Filter(CurRowBytes, PrvRowBytes, mBitmapData(StdBuffer), Interval)
  634.                 StdBuffer = StdBuffer + ZL + 1
  635.                 If Bpp < 8 Then
  636.                     ZLBytes = BerechneRowLen(8, State)
  637.                 Else
  638.                     ZLBytes = 0
  639.                 End If
  640.                 PutBuffer DstBuffer, CurRowBytes, 7, Nr, ZZ, ZLBytes
  641.                 Select Case Nr
  642.                     Case 2: Nr = 4
  643.                     Case 4: Nr = 6
  644.                     Case 6: Nr = 8
  645.                     Case 8: Nr = 2: ZZ = ZZ + 1
  646.                 End Select
  647.             Next idx
  648.         End If
  649.     End With
  650.     mBitmapData = DstBuffer
  651.     
  652. End Sub
  653.  
  654. Private Function BerechneRowLen(Bpp As Long, State As String) As Long
  655.     
  656.     Dim LenState        As Long
  657.     Dim Remain          As Long
  658.     Dim RemainLen       As Long
  659.     Dim RemainBytes     As Long
  660.     Dim NumBits         As Long
  661.     Dim NumBytes        As Long
  662.     Dim idx             As Long
  663.     Dim Stack           As Long
  664.     
  665.     Dim NBytes          As Long
  666.     Dim AnzRB           As Long
  667.     
  668.     LenState = Len(State)
  669.     RemainLen = mWidth Mod 8
  670.     
  671.     For idx = 1 To LenState
  672.         If CLng(Mid(State, idx, 1)) <= RemainLen Then
  673.             Stack = Stack + 1
  674.         Else
  675.             Exit For
  676.         End If
  677.     Next idx
  678.     If Bpp < 8 Then
  679.         Remain = IIf(RemainLen > 0, Bpp * Stack, 0)
  680.     Else
  681.         Remain = Stack * (Bpp / 8)
  682.     End If
  683.     NumBytes = (mWidth - RemainLen) / 8
  684.     NumBits = NumBytes * Bpp * LenState
  685.     RemainBytes = NumBits Mod 8
  686.     NBytes = (NumBits - RemainBytes) / 8
  687.     Select Case Bpp
  688.         Case Is < 8
  689.             Remain = Remain + RemainBytes
  690.             AnzRB = (Remain - Remain Mod 8) / 8
  691.             If Remain Mod 8 Then AnzRB = AnzRB + 1
  692.             BerechneRowLen = NBytes + AnzRB
  693.         Case Else
  694.             BerechneRowLen = NBytes + Remain
  695.     End Select
  696.  
  697. End Function
  698.  
  699. Private Sub Filter(CurRowBytes() As Byte, PrvRowBytes() As Byte, FType As Byte, Interval As Long)
  700.     
  701.     Dim PrvOff          As Long
  702.     Dim PrvVal          As Byte
  703.     Dim BPRow           As Long
  704.     Dim idx             As Long
  705.     Dim X               As Integer
  706.     Dim LeftPixOff      As Long
  707.     Dim LeftPix         As Byte
  708.     Dim UpperLeftPix    As Byte
  709.     Dim PaethPredictor  As Byte
  710.     Dim P(3)            As Integer
  711.     
  712.     BPRow = UBound(CurRowBytes) + 1
  713.     Select Case FType 'FilterType
  714.         'Case ft_NONE
  715.         Case ft_SUB
  716.             For idx = 0 To BPRow - 1
  717.                 PrvOff = idx - Interval
  718.                 If PrvOff >= 0 Then PrvVal = CurRowBytes(PrvOff)
  719.                 X = CInt(CurRowBytes(idx)) + CInt(PrvVal)
  720.                 Call CopyMemory(CurRowBytes(idx), X, 1)
  721.             Next idx
  722.         Case ft_UP
  723.             For idx = 0 To BPRow - 1
  724.                 PrvVal = PrvRowBytes(idx)
  725.                 X = CInt(CurRowBytes(idx)) + CInt(PrvVal)
  726.                 Call CopyMemory(CurRowBytes(idx), X, 1)
  727.             Next idx
  728.         Case ft_AVERAGE
  729.             For idx = 0 To BPRow - 1
  730.                 PrvOff = idx - Interval
  731.                 If PrvOff >= 0 Then PrvVal = CurRowBytes(PrvOff)
  732.                 X = CurRowBytes(idx) + (CInt(PrvRowBytes(idx)) + CInt(PrvVal)) \ 2
  733.                 Call CopyMemory(CurRowBytes(idx), X, 1)
  734.             Next idx
  735.         Case ft_PAETH
  736.             For idx = 0 To BPRow - 1
  737.                 LeftPixOff = idx - Interval
  738.                 If LeftPixOff >= 0 Then
  739.                     LeftPix = CurRowBytes(LeftPixOff)
  740.                     UpperLeftPix = PrvRowBytes(LeftPixOff)
  741.                 End If
  742.                 P(0) = CInt(LeftPix) + CInt(PrvRowBytes(idx)) - CInt(UpperLeftPix)
  743.                 P(1) = Abs(P(0) - LeftPix)
  744.                 P(2) = Abs(P(0) - PrvRowBytes(idx))
  745.                 P(3) = Abs(P(0) - UpperLeftPix)
  746.                 If (P(1) <= P(2)) And (P(1) <= P(3)) Then
  747.                     PaethPredictor = LeftPix
  748.                 ElseIf P(2) <= P(3) Then
  749.                     PaethPredictor = PrvRowBytes(idx)
  750.                 Else
  751.                     PaethPredictor = UpperLeftPix
  752.                 End If
  753.                 X = CInt(CurRowBytes(idx)) + CInt(PaethPredictor)
  754.                 Call CopyMemory(CurRowBytes(idx), X, 1)
  755.             Next idx
  756.     End Select
  757.     PrvRowBytes = CurRowBytes
  758.  
  759. End Sub
  760.  
  761. Private Sub PutBuffer(Buffer() As Byte, Rowbuffer() As Byte, RowType As Byte, RowNumber As Long, RowzΣhler As Long, RowLength As Long)
  762.     
  763.     Dim Anfang As Long
  764.     Dim Achtschritt As Long
  765.     Dim Zeile As Long
  766.     Dim Rowanfang As Long
  767.     Dim i As Long
  768.     Dim StdBuffer As Long
  769.     Dim Rowstand As Long
  770.     Dim Gr÷▀e As Long
  771.     Dim BytesPerPixel As Long
  772.     Dim Bpp As Long
  773.  
  774.     With mHeader
  775.         Bpp = BitsPerPixel
  776.         If Bpp >= 8 Then
  777.             BytesPerPixel = Abs(Bpp / 8)
  778.         Else
  779.             BytesPerPixel = 1
  780.             Call BitsToBytes(mHeader.Bitdepht, RowLength, Rowbuffer)
  781.         End If
  782.         Gr÷▀e = UBound(Rowbuffer) + 1
  783.         Rowanfang = .Width * (RowNumber - 1) * BytesPerPixel
  784.         Achtschritt = .Width * 8 * BytesPerPixel
  785.         Anfang = (Achtschritt * (RowzΣhler - 1)) + Rowanfang
  786.         'RowType: 1 = 1; 2 = 5; 3 = 1+5; 4 = 3+7; 5 = 1+3+5+7; 6 = 2+4+6+8; 7 = 1-8;
  787.         StdBuffer = Anfang
  788.         Select Case RowType
  789.             Case 1
  790.                 Do While Rowstand < Gr÷▀e
  791.                     CopyMemory Buffer(StdBuffer), Rowbuffer(Rowstand), BytesPerPixel
  792.                     StdBuffer = StdBuffer + (8 * BytesPerPixel)
  793.                     Rowstand = Rowstand + BytesPerPixel
  794.                 Loop
  795.             Case 2
  796.                 StdBuffer = StdBuffer + (4 * BytesPerPixel)
  797.                 Do While Rowstand < Gr÷▀e
  798.                     CopyMemory Buffer(StdBuffer), Rowbuffer(Rowstand), BytesPerPixel
  799.                     StdBuffer = StdBuffer + (8 * BytesPerPixel)
  800.                     Rowstand = Rowstand + BytesPerPixel
  801.                 Loop
  802.             Case 3
  803.                 Do While Rowstand < Gr÷▀e
  804.                     CopyMemory Buffer(StdBuffer), Rowbuffer(Rowstand), BytesPerPixel
  805.                     If Rowstand + BytesPerPixel < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (4 * BytesPerPixel)), Rowbuffer(Rowstand + BytesPerPixel), BytesPerPixel
  806.                     StdBuffer = StdBuffer + (8 * BytesPerPixel)
  807.                     Rowstand = Rowstand + (2 * BytesPerPixel)
  808.                 Loop
  809.             Case 4
  810.                 StdBuffer = StdBuffer + (2 * BytesPerPixel)
  811.                 Do While Rowstand < Gr÷▀e
  812.                     CopyMemory Buffer(StdBuffer), Rowbuffer(Rowstand), BytesPerPixel
  813.                     If Rowstand + BytesPerPixel < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (4 * BytesPerPixel)), Rowbuffer(Rowstand + BytesPerPixel), BytesPerPixel
  814.                     StdBuffer = StdBuffer + (8 * BytesPerPixel)
  815.                     Rowstand = Rowstand + (2 * BytesPerPixel)
  816.                 Loop
  817.             Case 5
  818.                 Do While Rowstand < Gr÷▀e
  819.                     CopyMemory Buffer(StdBuffer), Rowbuffer(Rowstand), BytesPerPixel
  820.                     If Rowstand + BytesPerPixel < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (2 * BytesPerPixel)), Rowbuffer(Rowstand + BytesPerPixel), BytesPerPixel
  821.                     If Rowstand + (2 * BytesPerPixel) < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (4 * BytesPerPixel)), Rowbuffer(Rowstand + (2 * BytesPerPixel)), BytesPerPixel
  822.                     If Rowstand + (3 * BytesPerPixel) < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (6 * BytesPerPixel)), Rowbuffer(Rowstand + (3 * BytesPerPixel)), BytesPerPixel
  823.                     StdBuffer = StdBuffer + (8 * BytesPerPixel)
  824.                     Rowstand = Rowstand + (4 * BytesPerPixel)
  825.                 Loop
  826.             Case 6
  827.                 StdBuffer = StdBuffer + BytesPerPixel
  828.                 Do While Rowstand < Gr÷▀e
  829.                     CopyMemory Buffer(StdBuffer), Rowbuffer(Rowstand), BytesPerPixel
  830.                     If Rowstand + BytesPerPixel < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (2 * BytesPerPixel)), Rowbuffer(Rowstand + BytesPerPixel), BytesPerPixel
  831.                     If Rowstand + (2 * BytesPerPixel) < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (4 * BytesPerPixel)), Rowbuffer(Rowstand + (2 * BytesPerPixel)), BytesPerPixel
  832.                     If Rowstand + (3 * BytesPerPixel) < Gr÷▀e Then CopyMemory Buffer(StdBuffer + (6 * BytesPerPixel)), Rowbuffer(Rowstand + (3 * BytesPerPixel)), BytesPerPixel
  833.                     StdBuffer = StdBuffer + (8 * BytesPerPixel)
  834.                     Rowstand = Rowstand + (4 * BytesPerPixel)
  835.                 Loop
  836.             Case 7
  837.                 CopyMemory Buffer(StdBuffer), Rowbuffer(0), UBound(Rowbuffer) + 1
  838.         End Select
  839.     End With
  840.  
  841. End Sub
  842.  
  843. Private Sub Swap4Bytes(Bytes As Long)
  844. '1234 >> 4321
  845.     Dim DstBytes As Long
  846.     
  847.     CopyMemory ByVal VarPtr(DstBytes), ByVal VarPtr(Bytes) + 3, 1
  848.     CopyMemory ByVal VarPtr(DstBytes) + 1, ByVal VarPtr(Bytes) + 2, 1
  849.     CopyMemory ByVal VarPtr(DstBytes) + 2, ByVal VarPtr(Bytes) + 1, 1
  850.     CopyMemory ByVal VarPtr(DstBytes) + 3, ByVal VarPtr(Bytes), 1
  851.     Bytes = DstBytes
  852.     
  853. End Sub
  854.  
  855. Private Sub SwapRGB()
  856. 'RGB >> BGR
  857.     Dim idx  As Long
  858.     Dim Temp As Byte
  859.  
  860.     For idx = 0 To UBound(mBitmapData) Step 3
  861.         Temp = mBitmapData(idx)
  862.         mBitmapData(idx) = mBitmapData(idx + 2)
  863.         mBitmapData(idx + 2) = Temp
  864.     Next idx
  865.  
  866. End Sub
  867.  
  868. Private Sub SwapRGBA()
  869. 'RGBA >> BGRA
  870.     Dim idx As Long
  871.     Dim Temp As Byte
  872.     
  873.     For idx = 0 To UBound(mBitmapData) Step 4
  874.         Temp = mBitmapData(idx)
  875.         If idx + 2 > UBound(mBitmapData) Then Exit For
  876.         mBitmapData(idx) = mBitmapData(idx + 2)
  877.         mBitmapData(idx + 2) = Temp
  878.     Next idx
  879.  
  880. End Sub
  881.