Why write my own code when there are so many libs I could use? Because libs are libs. I don't like this thing about programmers getting used to just depending on other people's code and not knowing what the code does. Sometimes bugs come up and you don't know why because you assumed wrong about how the lib does what it does or because the bug is already in the lib. Also, licenses, dependency hell, library versions, etc. My code is in native FreeBasic and I'm posting it here to the public domain so you guys can examine it, modify it and use it in your programs with the touches you want to give to it or inspire yourself in it to make your own, better code, if you like.
This current version, I have been testing and it seems like it works well. I threw at it all I could do with Gimp and it processed it well. It is able to read 24bit and 32bit true colour images (32bit meaning it contains an 8bit alpha channel) with or without RLE compression, both top to bottom and bottom to top. I only outputs RLE-compressed true colour images. It makes them 24bit if you haven't used transparency in your image and 32bit otherwise. Targa does support 15bit/16bit direct colour and indexed, but I have not implemented that yet. Regardless of your current Screen mode, images created with TargaLoad are 32bit per pixel and TargaSave will only accept that same format. FreeBasic allows you to use primitives on these images even if you're not in 32bit mode, but you can only Get and Put if in 32bit mode, so better just use 32bit mode when using these Subs.
How to use:
Code: Select all
ScreenRes 800, 600, 32
Dim p As Any Ptr
p = TargaLoad("myfile.tga")
If p = 0 Then
Print TargaErrorMessage
Else
Put (0, 0), p, PSet
End If
ImageDestroy p
'-------------------
p = ImageCreate(200, 200)
Circle (100, 100), 60, RGB(100, 200, 50)
Get (0, 0)-(199, 199), p
TargaSave "newfile.tga", p
If TargaError Then Print TargaErrorMessage
ImageDestroy pCode: Select all
#include "file.bi"
#define MAX_TARGA_WIDTH 8192
#define MAX_TARGA_HEIGHT 8192
Type TargaHeader Field = 1
IDlength As UByte
ColorMapType As UByte
ImageType As UByte
ColorMapStart As UShort
ColorMapLength As UShort
ColorMapDepth As UByte
XOffset As UShort
YOffset As UShort
ImageWidth As UShort
ImageHeight As UShort
PixelDepth As UByte
ImageDescriptor As UByte
End Type
Dim Shared TargaError As Short, TargaErrorMessage As String
Function TargaLoad(filename As String) As Any Pointer
'Reset error
TargaError = 0 : TargaErrorMessage = ""
If Not FileExists(filename) Then
TargaError = 201
TargaErrorMessage = "File not found"
Return 0
End If
Dim h As TargaHeader, f As Short
Dim localdepth As Integer 'Colour depth for current screen mode
Dim iptr As UByte Ptr 'Pointer to new image being generated
Dim linelength As Long 'Image line length within iptr in bytes
Dim imagestart As UByte Ptr 'Pointer to start of image data in iptr
Dim idatastart As Long 'File pointer to start of image data
Dim alphachannel As Byte 'Whether there's an alpha channel
Dim inverted As Byte 'Whether the image goes from bottom to top
Dim buffer As UByte Ptr 'Where compressed data will be loaded
Dim wp As Long 'Current write pointe (to image)
Dim rp As Long 'Current read pointer (from buffer)
'Get current color depth
ScreenControl 5, localdepth
'Open the file
f = FreeFile
Open filename For Binary Access Read As f
Get #f, 1, h 'Load the header
'Safety maximums have been set
'You can change these maximums to your preference
If h.ImageWidth > MAX_TARGA_WIDTH Or h.ImageHeight > MAX_TARGA_HEIGHT Then
TargaError = 202
TargaErrorMessage = "Image is too large"
Close f : Return 0
End If
'Calculate where image data starts in the file
idatastart = 19 + h.IDlength
If h.ColorMapType Then idatastart += h.ColorMapLength * (h.ColorMapDepth \ 8)
'See if image is inverted
If (h.ImageDescriptor And 32) = 0 Then inverted = -1
If (h.ImageDescriptor And 16) <> 0 Then
'X is inverted. Very unusual thing. Not currently supported
TargaError = 203
TargaErrorMessage = "Format not supported: X axis is inverted"
Close f : Return 0
End If
'See if there's an alpha channel
If h.ImageDescriptor And 15 Then alphachannel = -1
'Create a buffer of image size
iptr = ImageCreate(h.ImageWidth, h.ImageHeight, , 32)
ImageInfo iptr, , , , linelength, imagestart
'Load all image data from file to a buffer
buffer = Allocate(LOF(f) - idatastart + 1)
If buffer = 0 Then
'Could not allocate memory to load the file
TargaError = 204
TargaErrorMessage = "Could not allocate a buffer to decompress image"
ImageDestroy iptr
Close f
Return 0
End If
Get #f, idatastart, *buffer, LOF(f) - idatastart + 1
'==== Test for each of the possible supported formats ====
'True colour, RLE compressed, with alpha channel
If h.PixelDepth = 32 And h.ImageType = 10 And alphachannel <> 0 Then
Dim As UByte copying, repeating, sample(0 To 3)
Dim column As Long
rp = 0 'Reset read pointer
'For every line
For i As Long = 0 To h.ImageHeight - 1
'Calculate relative start of the line
If inverted Then
wp = (h.ImageHeight - i - 1) * linelength
Else
wp = i * linelength
End If
'Starting the line from column zero
column = 0
Do
'Check to see if there's RLE or non-RLE pending
If repeating Then
'Repeat one more sample of RLE block
For j As Byte = 0 To 3
imagestart[wp + j] = sample(j)
Next j
wp += 4
column += 1
repeating -= 1
ElseIf copying Then
'Copy one more sample from buffer
For j As Byte = 0 To 3
imagestart[wp + j] = buffer[rp + j]
Next j
wp += 4 : rp += 4
column += 1
copying -= 1
Else
'Process an RLE/non-RLE header
copying = buffer[rp]
rp += 1
If copying And 128 Then
repeating = copying - 127
copying = 0
For j As Byte = 0 To 3
sample(j) = buffer[rp + j]
Next j
rp += 4
Else
copying += 1
End If
End If
Loop Until column = h.ImageWidth
Next i
'True colour, RLE compressed, without alpha channel
ElseIf h.PixelDepth = 24 And h.ImageType = 10 And alphachannel = 0 Then
Dim As UByte copying, repeating, sample(0 To 3)
Dim column As Long
rp = 0 'Reset read pointer
'For every line
For i As Long = 0 To h.ImageHeight - 1
'Calculate relative start of the line
If inverted Then
wp = (h.ImageHeight - i - 1) * linelength
Else
wp = i * linelength
End If
'Starting the line from column zero
column = 0
Do
'Check to see if there's RLE or non-RLE pending
If repeating Then
'Repeat one more sample of RLE block
For j As Byte = 0 To 3
imagestart[wp + j] = sample(j)
Next j
wp += 4
column += 1
repeating -= 1
ElseIf copying Then
'Copy one more sample from buffer
For j As Byte = 0 To 2
imagestart[wp + j] = buffer[rp + j]
Next j
imagestart[wp + 3] = 255
wp += 4 : rp += 3
column += 1
copying -= 1
Else
'Process an RLE/non-RLE header
copying = buffer[rp]
rp += 1
If copying And 128 Then
repeating = copying - 127
copying = 0
For j As Byte = 0 To 2
sample(j) = buffer[rp + j]
Next j
sample(3) = 255
rp += 3
Else
copying += 1
End If
End If
Loop Until column = h.ImageWidth
Next i
'True colour, uncompressed, with alpha channel
ElseIf h.PixelDepth = 32 And h.ImageType = 2 And alphachannel <> 0 Then
rp = 0
'For every line
For i As Long = 0 To h.ImageHeight - 1
'Calculate relative start of the line
If inverted Then
wp = (h.ImageHeight - i - 1) * linelength
Else
wp = i * linelength
End If
For j As Long = 0 To 4 * h.ImageWidth - 1
imagestart[wp + j] = buffer[rp + j]
Next j
rp += 4 * h.ImageWidth
Next i
'True colour, uncompressed, without alpha channel
ElseIf h.PixelDepth = 24 And h.ImageType = 2 And alphachannel = 0 Then
rp = 0
'For every line
For i As Long = 0 To h.ImageHeight - 1
'Calculate relative start of the line
If inverted Then
wp = (h.ImageHeight - i - 1) * linelength
Else
wp = i * linelength
End If
For j As Long = 0 To h.ImageWidth - 1
imagestart[wp + 4 * j] = buffer[rp + 3 * j]
imagestart[wp + 4 * j + 1] = buffer[rp + 3 * j + 1]
imagestart[wp + 4 * j + 2] = buffer[rp + 3 * j + 2]
imagestart[wp + 4 * j + 3] = 255
Next j
rp += 3 * h.ImageWidth
Next i
Else
'Unsupported format
TargaError = 205
TargaErrorMessage = "Unsupported format"
Deallocate buffer
ImageDestroy iptr
Close f
Return 0
End If
Deallocate buffer
Close f
Return iptr
End Function
Sub TargaSave(filename As String, image As Any Ptr)
Dim As Integer iwidth, iheight, bypp, linelength
Dim As ULong Ptr imagestart
'Reset error information
TargaError = 0 : TargaErrorMessage = ""
'Make sure it's a valid image
If image = 0 Then
TargaError = 101
TargaErrorMessage = "No image in buffer"
Exit Sub
End If
ImageInfo image, iwidth, iheight, bypp, linelength, imagestart
If bypp <> 4 Then
TargaError = 102
TargaErrorMessage = "Not a 32bit image. Unsupported"
Exit Sub
End If
'See if the image contains any alpha information
Dim alphachannel As Byte = 0
For i As Long = 0 To iwidth * iheight - 1
If imagestart[i] ShR 24 <> 255 Then
alphachannel = -1
Exit For
End If
Next i
'Set up image header
Dim h As TargaHeader, f As Short
If alphachannel Then
h.PixelDepth = 32
h.ImageDescriptor = 8
Else
h.PixelDepth = 24
h.ImageDescriptor = 0
End If
h.ImageType = 10
h.ImageWidth = iwidth
h.ImageHeight = iheight
'Open file
f = FreeFile
If Open(filename For Output As f) Then
TargaError = 103
TargaErrorMessage = "Failed to create image file"
Exit Sub
Else
Close f
Open filename For Binary Access Write As f
End If
'Put header
Put #f, 1, h
'Compress image row by row
Dim rp As Long, column As Long, buffer As String
Dim count As Short, status As Byte, sample As Long
For i As Long = 0 To iheight - 1 'For every row...
'Calculate where to read the row from
rp = (iheight - i - 1) * linelength \ 4
buffer = ""
column = 0
status = 0 'Still don't know if RLE or not
count = 0 'Nothing pending
Do
Select Case status
Case 0 'Undefined
sample = imagestart[rp + column]
'If it's the last pixel, just push it
If column = iwidth - 1 Then
If alphachannel Then
buffer &= Chr(0) + MkL(sample)
Else
buffer &= Chr(0) + Left(MkL(sample), 3)
End If
Exit Do
End If
count = 0
If sample = imagestart[rp + column + 1] Then
status = 1 'Building an RLE block
Else
status = 2 'Building a non-RLE block
End If
Case 1 'RLE
If imagestart[rp + column] = sample Then
If count = 128 Then 'Block full. Push into the buffer
If alphachannel Then
buffer &= Chr(255) + MkL(sample)
Else
buffer &= Chr(255) + Left(MkL(sample), 3)
End If
count = 0
status = 0
Else
count += 1
column += 1
End If
Else
'Found an end for the RLE block
buffer &= Chr(127 + count)
If alphachannel Then
buffer &= MkL(sample)
Else
buffer &= Left(MkL(sample), 3)
End If
count = 0
status = 0
End If
Case Else 'Non-RLE
If imagestart[rp + column] = imagestart[rp + column + 1] Then
'End of non-RLE block
buffer &= Chr(count - 1)
For j As Short = column - count To column - 1
If alphachannel Then
buffer &= MkL(imagestart[rp + j])
Else
buffer &= Left(MkL(imagestart[rp + j]), 3)
End If
Next j
count = 0
status = 0
Else
If count = 128 Then 'Block full. Push into the buffer
buffer &= Chr(127)
For j As Short = column - 128 To column - 1
If alphachannel Then
buffer &= MkL(imagestart[rp + j])
Else
buffer &= Left(MkL(imagestart[rp + j]), 3)
End If
Next j
count = 0
status = 0
Else
count += 1
column += 1
End If
End If
End Select
Loop Until column = iwidth
If column = iwidth Then
If status = 1 Then
buffer &= Chr(127 + count)
If alphachannel Then
buffer &= MkL(sample)
Else
buffer &= Left(MkL(sample), 3)
End If
Else
buffer &= Chr(count - 1)
For j As Short = column - count To column - 1
If alphachannel Then
buffer &= MkL(imagestart[rp + j])
Else
buffer &= Left(MkL(imagestart[rp + j]), 3)
End If
Next j
End If
End If
Put #f, , buffer
Next i
'Targa v2.0 with no extensions
buffer = String(8, 0) + "TRUEVISION-XFILE." + Chr(0)
Put #f, , buffer
Close f
End Sub