VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsTGA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : clsTGA
' Date      : 6/23/2004
' Author    : ALKO (alfred.koppold@freenet.de)
' Purpose   : Class for handling *.TGA (Targa) files
'             NOTE: Battle.net's Battle.snp only supports the decoding of 24 and 32
'                   bit Targa files.
'---------------------------------------------------------------------------------------

Option Explicit

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type tgaheader
    info       As Byte      'length of image information block
    colortyp   As Byte      'DAC table or BGR format
    imagetyp   As Byte      'compressed or uncompressed
    origin     As Integer   'first entry in the DAC table
    colnumber  As Integer   'number of colors in the DAC table
    entrybits  As Byte      'entry size in the DAC table
    xvalue     As Integer   'x co-ordinate lower left corner
    yvalue     As Integer   'y co-ordinate lower left corner
    widt       As Integer   'image width
    Height     As Integer   'image height
    pixelsize  As Byte      'number of bits per pixel
    descriptor As Byte      'image descriptor
End Type

Private clsBitmap As New clsBitmap
Private clsFunctions As New clsFunctions

Private Orientation As Integer
Private Delivery() As Byte
Private BitmapData() As Byte
Private Header As tgaheader

Private i As Long
Private nWidth As Long
Private nHeight As Long
Private Scales As Integer
Private Automatic As Boolean
Private TW As ScTw

Public Function LoadTGA(ByVal FileName As String) As StdPicture
Dim nFreefile As Integer
    
nFreefile = FreeFile

Open FileName For Binary Lock Write As #nFreefile
    Seek #nFreefile, 1
    Get #nFreefile, , Header
Close #nFreefile

TW = modModule.PixelToTwips(CLng(Header.widt), CLng(Header.Height))

Select Case Header.pixelsize
    Case 24
        Call Read24bit(FileName)
    Case 32
        Call Read32bit(FileName)
End Select
End Function

Private Sub Read24bit(FileName As String)
Dim nFreefile As Integer
Dim nLineSize As Long
Dim Data() As Byte
Dim quad() As RGBQUAD
    
nFreefile = FreeFile
Open FileName For Binary Lock Write As #nFreefile
    Seek #nFreefile, 1
    Get #nFreefile, , Header
    With Header
        nWidth = .widt - .xvalue ' + 1
        nHeight = .Height - .yvalue ' + 1
        nLineSize = .widt * .pixelsize
    End With
    ReDim Data(LOF(nFreefile) - Len(Header))
    Get #nFreefile, , Data()
    Orientation = GetByte(Header.descriptor, 3)
Close #nFreefile
If Header.imagetyp = 9 Or Header.imagetyp = 10 Then
    Data = DecompressTGA(Data(), 24, nHeight, nWidth)
End If

'Sort from planes into a bitmap
Dim x As Long
Dim y As Long
Dim nStartPos As Long

ReDim quad(UBound(Data) / 3)
For x = 0 To UBound(Data) / 3 - 1
    With quad(x)
        .rgbBlue = Data(x * 3)
        .rgbGreen = Data(x * 3 + 1)
        .rgbRed = Data(x * 3 + 2)
    End With
Next x
ReDim BitmapData(UBound(quad) * 4 + 4)
Call RtlMoveMemory(BitmapData(0), quad(0), UBound(BitmapData))
Call clsBitmap.CreateBitmap_24(BitmapData, nWidth, nHeight, Orientation)
End Sub

Private Sub Read32bit(FileName As String)
Dim nFreefile As Integer
Dim nLineSize As Long
Dim Data() As Byte
Dim quad() As RGBQUAD

nFreefile = FreeFile

Open FileName For Binary Lock Write As #nFreefile
    Seek #nFreefile, 1
    Get #nFreefile, , Header
    With Header
        nWidth = .widt - .xvalue ' + 1
        nHeight = .Height - .yvalue ' + 1
        nLineSize = .widt * .pixelsize
    End With
    ReDim Data(LOF(nFreefile) - Len(Header))
    Get #nFreefile, , Data()
    Orientation = GetByte(Header.descriptor, 3)
    Close #nFreefile
If Header.imagetyp = 9 Or Header.imagetyp = 10 Then
    Data = DecompressTGA(Data(), 32, nHeight, nWidth)
End If

'Sort from planes into a bitmap
Dim x As Long
Dim y As Long
Dim nStartPos As Long
    
ReDim quad(UBound(Data) / 4)
For x = 0 To UBound(Data) / 4 - 1
    With quad(x)
        .rgbBlue = Data(x * 4)
        .rgbGreen = Data(x * 4 + 1)
        .rgbRed = Data(x * 4 + 2)
    End With
Next x

ReDim BitmapData(UBound(quad) * 4 + 4)
Call RtlMoveMemory(BitmapData(0), quad(0), UBound(BitmapData))
Call clsBitmap.CreateBitmap_24(BitmapData, nWidth, nHeight, Orientation)
End Sub

Private Function DecompressTGA(RLEStream() As Byte, Bits As Long, Height As Long, Width As Long) As Byte()
Dim InitSize As Long
Dim Temp() As Byte
Dim n As Long
Dim k As Boolean
Dim b As Long
Dim l As Long
Dim finished As Long
Dim z As Long
Dim Length As Long
Dim ByteAmount As Long

ByteAmount = Bits / 8
InitSize = CLng(Height * Width * ByteAmount)
ReDim Temp(0 To InitSize)
Do While finished < InitSize
    If l > UBound(RLEStream) Then GoTo Ende
        z = 0
        If RLEStream(l) > 127 Then
            n = RLEStream(l) - 127
            For b = 0 To n - 1
                RtlMoveMemory Temp(finished), RLEStream(l + 1), ByteAmount
                finished = finished + ByteAmount
            Next b
            k = True
        Else
            n = RLEStream(l) + 1
            Length = n * ByteAmount
            RtlMoveMemory Temp(finished), RLEStream(l + 1), Length
            k = False
            z = z + Length
            finished = finished + z
        End If
        If k = True Then
            l = ByteAmount + 1 + l
            n = z + (n * ByteAmount) + 1
        Else
            l = (n * ByteAmount + 1) + l
            n = z + n
        End If
    Loop

Ende:
    DecompressTGA = Temp
End Function

Private Function GetByte(Bytes As Byte, Position As Long) As Integer
GetByte = 0
Select Case Position
    Case 1
        If Bytes And 128 Then GetByte = 1
    Case 2
        If Bytes And 64 Then GetByte = 1
    Case 3
        If Bytes And 32 Then GetByte = 1
    Case 4
        If Bytes And 16 Then GetByte = 1
    Case 5
        If Bytes And 8 Then GetByte = 1
    Case 6
        If Bytes And 4 Then GetByte = 1
    Case 7
        If Bytes And 2 Then GetByte = 1
    Case 8
        If Bytes And 1 Then GetByte = 1
End Select
End Function

Public Function DrawTGA(PicObj As Object)
Call clsBitmap.DrawBitmap(nWidth, nHeight, PicObj, Automatic)
End Function

Public Property Get TGAWidth() As Long
Select Case Scales
    Case 0
        TGAWidth = nWidth
    Case 1
        TGAWidth = TW.TwipWidth
End Select
End Property

Public Property Get TGAHeight() As Long
Select Case Scales
    Case 0
        TGAHeight = nHeight
    Case 1
        TGAHeight = TW.TwipHeight
End Select
End Property

Public Property Get Compressed() As Boolean
Select Case Header.imagetyp
    Case 9
        Compressed = True
    Case 10
        Compressed = True
    Case Else
        Compressed = False
End Select
End Property

Public Property Get Bpp() As Integer
Bpp = CInt(Header.pixelsize)
End Property

Public Property Get IsTGA() As Boolean
Dim Test As Boolean

Test = True
Select Case Header.imagetyp
    Case 1
    Case 2
    Case 3
    Case 9
    Case 10
    Case 11
    Case 32
    Case 33
    Case Else
        Test = False
End Select

Select Case Header.pixelsize
    Case &H18 '24bpp
    Case &H20 '32bpp
    Case Else
        Test = False
End Select
IsTGA = Test
End Property

Public Property Get ScaleMode() As Integer
ScaleMode = Scales
End Property

Public Property Let ScaleMode(ByVal vNewValue As Integer)
If vNewValue > 0 Then vNewValue = 1
If vNewValue <> Scales Then
    Scales = vNewValue
End If
End Property

Public Property Get Autoscale() As Boolean
Autoscale = Automatic
End Property

Public Property Let Autoscale(ByVal vNewValue As Boolean)
Automatic = vNewValue
End Property

Private Sub Class_Initialize()
Automatic = True
Scales = 1
End Sub
