home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Images-in-196292162006.psc / cTexture.cls < prev    next >
Text File  |  2006-01-05  |  7KB  |  285 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 = "cTexture"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Private Type BITMAP           '14 bytes
  17.     bmType As Long
  18.     bmWidth As Long
  19.     bmHeight As Long
  20.     bmWidthBytes As Long
  21.     bmPlanes As Long
  22.     bmBitsPixel As Long
  23.     bmBits As Long
  24. End Type
  25.  
  26. Private Type BITMAPINFOHEADER  '40 bytes
  27.     biSize As Long
  28.     biWidth As Long
  29.     biHeight As Long
  30.     biPlanes As Integer
  31.     biBitCount As Integer
  32.     biCompression As Long
  33.     biSizeImage As Long
  34.     biXPelsPerMeter As Long
  35.     biYPelsPerMeter As Long
  36.     biClrUsed As Long
  37.     biClrImportant As Long
  38. End Type
  39.  
  40. Private Type RGBQUAD           '4 bytes
  41.     rgbBlue As Byte
  42.     rgbGreen As Byte
  43.     rgbRed As Byte
  44.     rgbReserved As Byte
  45. End Type
  46.  
  47. Public Enum ENUImg1_FILETYPE
  48.     FILETYPE_BMP = 0
  49.     FILETYPE_TGA = 1
  50.     FILETYPE_RAW = 2
  51. End Enum
  52.  
  53. Public Enum ENUImg1_FILTER
  54.     FILTER_NEAREST = 0
  55.     FILTER_LINEAR = 1
  56.     FILTER_MIPMAPPED = 2
  57. End Enum
  58.  
  59. Private Img1s(3) As Long
  60. Private Img2(3) As Long
  61. Private m_Filter As Integer
  62. Private m_Width As Long, m_Height As Long
  63.  
  64. Public Sub useTexture()
  65.  
  66.     glBindTexture glTexture2D, Img1s(m_Filter)
  67.     glBindTexture glTexture2D, Img2(0)
  68.  
  69. End Sub
  70.  
  71. Public Sub loadTexture(Filename As String, FileType As ENUImg1_FILETYPE, Optional Width As Long, Optional Height As Long)
  72.  
  73.     Select Case FileType
  74.         ' BMP
  75.       Case 0:
  76.         loadBitmap Filename
  77.         ' TGA
  78.       Case 1:
  79.         loadTGA Filename
  80.         ' RAW
  81.       Case 2:
  82.         If IsMissing(Width) Or IsMissing(Height) Then
  83.             Exit Sub '>---> Bottom
  84.         End If
  85.         loadRAW Filename, Width, Height
  86.     End Select
  87.     
  88.     setFilter FILTER_NEAREST
  89.  
  90. End Sub
  91.  
  92. Private Sub loadRAW(Filename As String, Width As Long, Height As Long)
  93.  
  94.   ' Assumes RGB top to bottom 24BPP format. No header info
  95.   
  96.   Dim ff As Integer
  97.   Dim b() As Byte
  98.   Dim c As Long
  99.   Dim t As Byte
  100.   Dim i As Long, a As Long
  101.     
  102.     ff = FreeFile()
  103.     ReDim b((Width * Height) * 4)
  104.     
  105.     Open Filename For Binary As ff
  106.     Get ff, , b
  107.     Close ff
  108.     
  109.     makeTexturesFromByteArray b, Width, Height, True
  110.  
  111. End Sub
  112.  
  113. Private Sub loadBitmap(Filename As String)
  114.  
  115.   Dim bmFile As BITMAPFILEHEADER
  116.   Dim bmInfo As BITMAPINFOHEADER
  117.   Dim bmRGB() As RGBQUAD
  118.   Dim iFile As Integer
  119.   Dim lImageSize As Long
  120.   Dim iPixelSize As Integer
  121.   Dim baImageData() As Byte
  122.   
  123.     iFile = FreeFile
  124.   
  125.     Open Filename For Binary As iFile
  126.     Get #iFile, , bmFile
  127.     Get #iFile, , bmInfo
  128.         
  129.     If (bmInfo.biBitCount < 24) Then
  130.         ReDim bmRGB(bmInfo.biClrUsed)
  131.           
  132.         Get #iFile, , bmRGB
  133.     End If
  134.         
  135.     iPixelSize = bmInfo.biBitCount / 8
  136.         
  137.     lImageSize = bmInfo.biWidth * bmInfo.biHeight * iPixelSize
  138.         
  139.     ReDim baImageData(lImageSize)
  140.         
  141.     Get #iFile, , baImageData
  142.     Close #iFile
  143.   
  144.     makeTexturesFromByteArray baImageData, bmInfo.biWidth, bmInfo.biHeight, False
  145.  
  146. End Sub
  147.  
  148. Private Sub loadTGA(Filename As String)
  149.  
  150.   Dim ty(2) As Byte
  151.   Dim inf(5) As Byte
  152.   Dim imageData() As Byte
  153.   Dim imageWidth As Long, imageHeight As Long
  154.   Dim imageBits As Integer, s As Long
  155.   Dim ff As Integer
  156.     
  157.     ff = FreeFile
  158.     
  159.     Open Filename For Binary As ff
  160.     Get ff, , ty
  161.     Get ff, 13, inf
  162.         
  163.     If Not ty(1) = 0 And Not ty(2) = 2 Then
  164.         MsgBox "Bad TGA Image Type"
  165.         Exit Sub '>---> Bottom
  166.     End If
  167.         
  168.     imageWidth = CLng(inf(0) + inf(1) * 256)
  169.     imageHeight = CLng(inf(2) + inf(3) * 256)
  170.     imageBits = CInt(inf(4))
  171.         
  172.     s = imageWidth * imageHeight
  173.         
  174.     If Not imageBits = 32 And Not imageBits = 24 Then
  175.         MsgBox "Unsupported bitdepth"
  176.         Exit Sub '>---> Bottom
  177.     End If
  178.         
  179.     ReDim imageData(s * (imageBits \ 8))
  180.     imageData = getData(ff, s, imageBits)
  181.     Close ff
  182.     
  183.     makeTexturesFromByteArray imageData, imageWidth, imageHeight, IIf(imageBits = 32, True, False)
  184.  
  185. End Sub
  186.  
  187. Private Function getRGBA(FileNumber As Integer, s As Long) As Byte()
  188.  
  189.   Dim b() As Byte
  190.   Dim t As Byte
  191.   Dim i As Long
  192.     
  193.     ReDim b((s - 1) * 4)
  194.     
  195.     Get FileNumber, , b
  196.     
  197.     getRGBA = b
  198.  
  199. End Function
  200.  
  201. Private Function getRGB(FileNumber As Integer, s As Long) As Byte()
  202.  
  203.   Dim b() As Byte
  204.   Dim t As Byte
  205.   Dim i As Long
  206.     
  207.     ReDim b((s - 1) * 3)
  208.     
  209.     Get FileNumber, , b
  210.     
  211.     getRGB = b
  212.  
  213. End Function
  214.  
  215. Private Function getData(FileNumber As Integer, s As Long, iBits As Integer) As Byte()
  216.  
  217.     If iBits = 32 Then
  218.         getData = getRGBA(FileNumber, s)
  219.       Else 'NOT IBITS...
  220.         getData = getRGB(FileNumber, s)
  221.     End If
  222.  
  223. End Function
  224.  
  225. Private Sub makeTexturesFromByteArray(ByRef b() As Byte, ByVal w As Long, ByVal h As Long, hasAlpha As Boolean)
  226.  
  227.     glGenTextures 3, Img1s(0)
  228.  
  229.     glBindTexture glTexture2D, Img1s(0)
  230.     glTexParameteri glTexture2D, tpnTextureMagFilter, GL_NEAREST
  231.     glTexParameteri glTexture2D, tpnTextureMinFilter, GL_NEAREST
  232.     glTexImage2D glTexture2D, 0, IIf(hasAlpha = True, 4, 3), w, h, _
  233.                  0, tiBGRExt, GL_UNSIGNED_BYTE, b(0)
  234.     
  235.     glGenTextures 3, Img2(0)
  236.  
  237.     glBindTexture glTexture2D, Img2(0)
  238.     glTexParameteri glTexture2D, tpnTextureMagFilter, GL_NEAREST
  239.     glTexParameteri glTexture2D, tpnTextureMinFilter, GL_NEAREST
  240.     glTexImage2D glTexture2D, 0, IIf(hasAlpha = True, 4, 3), w, h, _
  241.                  0, tiBGRExt, GL_UNSIGNED_BYTE, b(0)
  242.     
  243.     glBindTexture glTexture2D, Img1s(1)
  244.     glTexParameteri glTexture2D, tpnTextureMagFilter, GL_LINEAR
  245.     glTexParameteri glTexture2D, tpnTextureMinFilter, GL_LINEAR
  246.     glTexImage2D glTexture2D, 0, IIf(hasAlpha = True, 4, 3), w, h, _
  247.                  0, tiBGRExt, GL_UNSIGNED_BYTE, b(0)
  248.   
  249.     glBindTexture glTexture2D, Img1s(2)
  250.     glTexParameteri glTexture2D, tpnTextureMagFilter, GL_LINEAR
  251.     glTexParameteri glTexture2D, tpnTextureMinFilter, GL_LINEAR_MIPMAP_NEAREST
  252.     gluBuild2DMipmaps glTexture2D, IIf(hasAlpha = True, 4, 3), w, h, tiBGRExt, _
  253.                       GL_UNSIGNED_BYTE, ByVal VarPtr(b(0))
  254.         
  255.     m_Width = w
  256.     m_Height = h
  257.  
  258. End Sub
  259.  
  260. Public Sub setFilter(Filter As ENUImg1_FILTER)
  261.  
  262.     m_Filter = Filter
  263.  
  264. End Sub
  265.  
  266. Public Function getFilter() As ENUImg1_FILTER
  267.  
  268.     getFilter = m_Filter
  269.  
  270. End Function
  271.  
  272. Public Sub unloadTexture()
  273.  
  274.     glDeleteTextures 3, Img1s(0)
  275.  
  276. End Sub
  277.  
  278. Private Sub Class_Terminate()
  279.  
  280.     unloadTexture
  281.  
  282. End Sub
  283.  
  284.  
  285.