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 / clsLoadPCX.cls < prev    next >
Text File  |  2009-01-22  |  5KB  |  164 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 = "clsLoadPCX"
  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 '30 Byte
  19.     Manufacturer            As Byte      '1
  20.     Version                 As Byte      '1
  21.     Encoding                As Byte      '1
  22.     Bpp                     As Byte      '1
  23.     Xmin                    As Integer   '2
  24.     Ymin                    As Integer   '2
  25.     Xmax                    As Integer   '2
  26.     Ymax                    As Integer   '2
  27.     HDpi                    As Integer   '2
  28.     VDpi                    As Integer   '2
  29.     ColorPalette(15)        As RGBTRIPLE '3
  30.     Reserved1               As Byte      '1
  31.     Planes                  As Byte      '1
  32.     BytesPerLine            As Integer   '2
  33.     PaletteInfo             As Integer   '2
  34.     HScreenSize             As Integer   '2
  35.     VScreenSize             As Integer   '2
  36.     Reserved2(53)           As Byte      '1
  37. End Type
  38.  
  39. Private mHeader             As HEADER
  40. Private mWidth              As Long
  41. Private mHeight             As Long
  42. Private mBitmapData()       As Byte
  43.  
  44. Private mNumFile            As Integer
  45. Private mLineSize           As Long
  46.  
  47. Public Sub LoadPCX(ByVal Filename As String)
  48.     
  49.     mNumFile = FreeFile
  50.     Open Filename For Binary Lock Write As #mNumFile
  51.         With mHeader
  52.             Get #mNumFile, , mHeader
  53.             ReDim mBitmapData(LOF(mNumFile) - Len(mHeader))
  54.             Get #mNumFile, , mBitmapData()
  55.             If .Encoding = 1 Then Call DecompRLE(mBitmapData)
  56.             mWidth = .Xmax - .Xmin + 1
  57.             mHeight = .Ymax - .Ymin + 1
  58.             mLineSize = .Planes * .BytesPerLine
  59.             Select Case .Bpp
  60.                 Case 1: If .Planes = 1 Then Call Read_bd01
  61.                 Case 4: If .Planes = 1 Then Call Read_bd04
  62.                 Case 8: If .Planes = 1 Then Call Read_bd08 Else Call Read_bd24
  63.             End Select
  64.         End With
  65.     Close #mNumFile
  66.     Call DrawBitmap(mWidth, mHeight)
  67.    
  68.     
  69. End Sub
  70.  
  71. Private Sub Read_bd01()
  72.     
  73.     Call CreateTable(ct_GRAY, bd_01)
  74.     Call MakeBitmap(mLineSize, mHeight, mBitmapData, True)
  75.     Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_01)
  76.  
  77. End Sub
  78.  
  79. Private Sub Read_bd04()
  80.         
  81.     Call QuickColorTable_04(mHeader.ColorPalette)
  82.     Call MakeBitmap(mLineSize, mHeight, mBitmapData, True)
  83.     Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_04)
  84.  
  85. End Sub
  86.  
  87. Private Sub Read_bd08()
  88.  
  89.     Dim ColorPalette(255) As RGBTRIPLE
  90.     Dim PalByte As Byte
  91.     Dim idx As Long
  92.  
  93.     Seek #mNumFile, LOF(mNumFile) - 768
  94.     Get #mNumFile, , PalByte
  95.     If PalByte = 12 Then
  96.         Seek #mNumFile, LOF(mNumFile) - 767
  97.         Get #mNumFile, , ColorPalette()
  98.     Else
  99.         For idx = 0 To 255
  100.             ColorPalette(idx).Blue = idx
  101.             ColorPalette(idx).Green = idx
  102.             ColorPalette(idx).Red = idx
  103.         Next idx
  104.     End If
  105.  
  106.     Call QuickColorTable_08(ColorPalette)
  107.     Call MakeBitmap(mLineSize, mHeight, mBitmapData, True)
  108.     Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08)
  109.  
  110. End Sub
  111.  
  112. Private Function Read_bd24()
  113.     
  114.     Dim quad()  As RGBQUAD
  115.     Dim X       As Long
  116.     Dim Y       As Long
  117.     Dim idx     As Long
  118.     
  119.     ReDim quad(mWidth * mHeight)
  120.     mHeight = mHeight - 1
  121.     For Y = 0 To mHeight
  122.         For X = 0 To mWidth - 1
  123.             idx = Y * mHeader.BytesPerLine * 3 + X
  124.             With quad((X + (mHeight - Y) * mWidth))
  125.                 .rgbRed = mBitmapData(idx)
  126.                 .rgbGreen = mBitmapData(idx + mHeader.BytesPerLine)
  127.                 .rgbBlue = mBitmapData(idx + mHeader.BytesPerLine * 2)
  128.             End With
  129.         Next X
  130.     Next Y
  131.     ReDim mBitmapData(UBound(quad) * 4 + 4)
  132.     CopyMemory mBitmapData(0), quad(0), UBound(mBitmapData) + 1
  133.     mHeight = mHeight + 1
  134.     Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_32)
  135.     
  136. End Function
  137.  
  138. Private Sub DecompRLE(Buffer() As Byte)
  139.     
  140.     Dim TempBuffer() As Byte
  141.     Dim State        As Long
  142.     Dim idx          As Long
  143.     Dim IdxRepeat    As Long
  144.     Dim NumRepeat    As Long
  145.          
  146.     For idx = 0 To UBound(Buffer) - 1
  147.         NumRepeat = Buffer(idx)
  148.         If NumRepeat >= 192 Then
  149.             idx = idx + 1
  150.             For IdxRepeat = 1 To NumRepeat - 192
  151.                 ReDim Preserve TempBuffer(State)
  152.                 TempBuffer(State) = Buffer(idx)
  153.                 State = State + 1
  154.             Next IdxRepeat
  155.         Else
  156.             ReDim Preserve TempBuffer(State)
  157.             TempBuffer(State) = NumRepeat
  158.             State = State + 1
  159.         End If
  160.     Next idx
  161.     Buffer = TempBuffer
  162.  
  163. End Sub
  164.