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 / clsLoadTGA.cls < prev    next >
Text File  |  2009-01-22  |  8KB  |  222 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 = "clsLoadTGA"
  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 '18 Byte
  19.     IDSize          As Byte      '1
  20.     ColorMapType    As Byte      '1
  21.     ImageType       As Byte      '1     0=none,1=indexed,2=rgb,3=grey,>8=rle
  22.     ColorMapStart   As Integer   '2
  23.     ColorMapLenght  As Integer   '2
  24.     ColorMapBits    As Byte      '1
  25.     XStart          As Integer   '2
  26.     YStart          As Integer   '2
  27.     Width           As Integer   '2
  28.     Height          As Integer   '2
  29.     Bits            As Byte      '1
  30.     Descriptor      As Byte      '1
  31. End Type
  32.  
  33. Private Type PALLET2
  34.     Byte1           As Byte
  35.     Byte2           As Byte
  36. End Type
  37.  
  38. Private mHeader         As HEADER
  39. Private mWidth          As Long
  40. Private mHeight         As Long
  41. Private mBitmapData()   As Byte
  42.  
  43. Private mNumFile        As Integer
  44. Private mNumPixel       As Long
  45.  
  46. Public Sub LoadTGA(ByVal Filename As String)
  47.     
  48.     mNumFile = FreeFile
  49.     Open Filename For Binary As #mNumFile
  50.         Get #mNumFile, , mHeader
  51.         With mHeader
  52.             mWidth = .Width - .XStart
  53.             mHeight = .Height - .YStart
  54.             mNumPixel = mWidth * mHeight
  55.             Select Case .Bits
  56.                 Case 8:  Read_bd08
  57.                 Case 16: Read_bd16
  58.                 Case 24: Read_bd24
  59.                 Case 32: Read_bd32
  60.             End Select
  61.         End With
  62.     Close #mNumFile
  63.     Call DrawBitmap(mWidth, mHeight)
  64.  
  65. End Sub
  66.  
  67. Private Sub Read_bd08()
  68.     
  69.     Dim Pal(255)    As RGBTRIPLE
  70.     Dim Pal16()     As PALLET2
  71.     Dim Pal24()     As RGBTRIPLE
  72.     Dim Pal32()     As RGBQUAD
  73.     Dim idx         As Integer
  74.     
  75.     Select Case mHeader.ColorMapBits
  76.         Case 16
  77.             ReDim Pal16(mHeader.ColorMapLenght - 1)
  78.             Get #mNumFile, , Pal16
  79.             For idx = 0 To UBound(Pal16)
  80.                 If GetByte(Pal16(idx).Byte1, 1) Then Pal(idx).Blue = 16
  81.                 If GetByte(Pal16(idx).Byte1, 2) Then Pal(idx).Blue = Pal(idx).Blue + 8
  82.                 If GetByte(Pal16(idx).Byte1, 3) Then Pal(idx).Blue = Pal(idx).Blue + 4
  83.                 If GetByte(Pal16(idx).Byte1, 4) Then Pal(idx).Blue = Pal(idx).Blue + 2
  84.                 If GetByte(Pal16(idx).Byte1, 5) Then Pal(idx).Blue = Pal(idx).Blue + 1
  85.                 If GetByte(Pal16(idx).Byte1, 6) Then Pal(idx).Green = 16
  86.                 If GetByte(Pal16(idx).Byte1, 7) Then Pal(idx).Green = Pal(idx).Green + 8
  87.                 If GetByte(Pal16(idx).Byte1, 8) Then Pal(idx).Green = Pal(idx).Green + 4
  88.                 If GetByte(Pal16(idx).Byte2, 1) Then Pal(idx).Green = Pal(idx).Green + 2
  89.                 If GetByte(Pal16(idx).Byte2, 2) Then Pal(idx).Green = Pal(idx).Green + 1
  90.                 If GetByte(Pal16(idx).Byte2, 3) Then Pal(idx).Red = 16
  91.                 If GetByte(Pal16(idx).Byte2, 4) Then Pal(idx).Red = Pal(idx).Red + 8
  92.                 If GetByte(Pal16(idx).Byte2, 5) Then Pal(idx).Red = Pal(idx).Red + 4
  93.                 If GetByte(Pal16(idx).Byte2, 6) Then Pal(idx).Red = Pal(idx).Red + 2
  94.                 If GetByte(Pal16(idx).Byte2, 7) Then Pal(idx).Red = Pal(idx).Red + 1
  95.                 Pal(idx).Blue = Pal(idx).Blue * 4
  96.                 Pal(idx).Green = Pal(idx).Green * 4
  97.                 Pal(idx).Red = Pal(idx).Red * 4
  98.             Next idx
  99.         Case 24
  100.             ReDim Pal24(mHeader.ColorMapLenght - 1)
  101.             Get #mNumFile, , Pal24
  102.             For idx = 0 To UBound(Pal24)
  103.                 Pal(idx).Red = Pal24(idx).Blue 'Attention !! Red = Blue (rgb>>bgra)
  104.                 Pal(idx).Green = Pal24(idx).Green
  105.                 Pal(idx).Blue = Pal24(idx).Red 'Attention !! Blue = Red (rgb>>bgra)
  106.             Next idx
  107.         Case 32
  108.             ReDim Pal32(mHeader.ColorMapLenght - 1)
  109.             Get #mNumFile, , Pal32
  110.             For idx = 0 To UBound(Pal32)
  111.                 Pal(idx).Red = Pal32(idx).rgbRed
  112.                 Pal(idx).Green = Pal32(idx).rgbGreen
  113.                 Pal(idx).Blue = Pal32(idx).rgbBlue
  114.             Next idx
  115.         Case Else
  116.             ReDim mBitmapData(LOF(mNumFile) - Len(mHeader))
  117.             For idx = 0 To 255
  118.                 Pal(idx).Blue = idx
  119.                 Pal(idx).Green = idx
  120.                 Pal(idx).Red = idx
  121.             Next idx
  122.     End Select
  123.     Call QuickColorTable_08(Pal)
  124.     ReDim mBitmapData(LOF(mNumFile) - Len(mHeader) - 765) '765=((mHeader.ColorMapLenght - 1) * 3))
  125.     Get #mNumFile, , mBitmapData()
  126.     If mHeader.ImageType > 8 Then
  127.         MsgBox "Compression under consruction"
  128.     Else
  129.         Call MakeBitmap(mWidth, mHeight, mBitmapData)
  130.         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_08)
  131.     End If
  132.     
  133. End Sub
  134.  
  135. Private Sub Read_bd16()
  136.     
  137.     ReDim mBitmapData(LOF(mNumFile) - Len(mHeader))
  138.     Get #mNumFile, , mBitmapData()
  139.     If mHeader.ImageType > 8 Then
  140.         MsgBox "Compression under consruction"
  141.     Else
  142.         Call MakeBitmap(mWidth * 2, mHeight, mBitmapData)
  143.         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_16)
  144.     End If
  145.     
  146. End Sub
  147.  
  148. Private Sub Read_bd24()
  149.     
  150.     Dim quad()      As RGBQUAD
  151.     Dim idx         As Long
  152.     Dim idx3        As Long
  153.     
  154.     ReDim mBitmapData(LOF(mNumFile) - Len(mHeader))
  155.     Get #mNumFile, , mBitmapData()
  156.     If mHeader.ImageType > 8 Then
  157.         MsgBox "Compression under consruction"
  158.     Else
  159.         ReDim quad(UBound(mBitmapData) / 3)
  160.         For idx = 0 To UBound(mBitmapData) / 3 - 1
  161.             With quad(idx)
  162.                 idx3 = idx * 3
  163.                 .rgbBlue = mBitmapData(idx3)
  164.                 .rgbGreen = mBitmapData(idx3 + 1)
  165.                 .rgbRed = mBitmapData(idx3 + 2)
  166.             End With
  167.         Next idx
  168.         ReDim mBitmapData(UBound(quad) * 4 + 4)
  169.         CopyMemory mBitmapData(0), quad(0), UBound(mBitmapData)
  170.         Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_32)
  171.     End If
  172.     
  173. End Sub
  174.  
  175. Private Sub Read_bd32()
  176.     
  177.     Dim quad()      As RGBQUAD
  178.     Dim idx         As Long
  179.     Dim idx4        As Long
  180.     
  181.     ReDim mBitmapData(LOF(mNumFile) - Len(mHeader))
  182.     Get #mNumFile, , mBitmapData()
  183.     If mHeader.ImageType > 8 Then
  184.         MsgBox "Compression under consruction"
  185.     Else
  186.         If mAlpha = True Then
  187.             Call MakeAlpha(mWidth, mHeight, mBitmapData)
  188.             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_24)
  189.         Else
  190.             ReDim quad(UBound(mBitmapData) / 4)
  191.             For idx = 0 To UBound(mBitmapData) / 4 - 1
  192.                 With quad(idx)
  193.                     idx4 = idx * 4
  194.                     .rgbBlue = mBitmapData(idx4)
  195.                     .rgbGreen = mBitmapData(idx4 + 1)
  196.                     .rgbRed = mBitmapData(idx4 + 2)
  197.                 End With
  198.             Next idx
  199.             ReDim mBitmapData(UBound(quad) * 4 + 4)
  200.             CopyMemory mBitmapData(0), quad(0), UBound(mBitmapData)
  201.             Call CreateBitmap(mWidth, mHeight, mBitmapData, bd_32)
  202.         End If
  203.     End If
  204.     
  205. End Sub
  206.  
  207. Private Function GetByte(Bytes As Byte, Position As Byte) As Byte
  208.     
  209.     GetByte = 0
  210.     Select Case Position
  211.         Case 1: If Bytes And 128 Then GetByte = 1   ' 128= 10000000
  212.         Case 2: If Bytes And 64 Then GetByte = 1    ' 64 = 01000000
  213.         Case 3: If Bytes And 32 Then GetByte = 1    ' 32 = 00100000
  214.         Case 4: If Bytes And 16 Then GetByte = 1    ' 16 = 00010000
  215.         Case 5: If Bytes And 8 Then GetByte = 1     ' 8  = 00001000
  216.         Case 6: If Bytes And 4 Then GetByte = 1     ' 4  = 00000100
  217.         Case 7: If Bytes And 2 Then GetByte = 1     ' 2  = 00000010
  218.         Case 8: If Bytes And 1 Then GetByte = 1     ' 1  = 00000001
  219.     End Select
  220.  
  221. End Function
  222.