Buchempfehlung
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Mikrocomputertechnik mit Controllern der Atmel AVR-RISC-Familie
Umfassend, aber leicht verständlich führt dieses Buch in die Programmierung von ATMEL AVR Mikrocontrollern ein. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Grafik und Fonts

TGA Datei speichern

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.Mitgliedcsde_rats 23.09.2007

Wie man eine TGA Bild speichern kann, demonstriert dieses Programm.

#include "fbgfx.bi"
Type TGAHEADER Field=1
  As Byte  idlength
  As Byte  colourmaptype
  As Byte  datatypecode
  As Short colourmaporigin
  As Short colourmaplength
  As Byte  colourmapdepth
  As Short x_origin
  As Short y_origin
  As Short Width
  As Short height
  As Byte  bitsperpixel
  As Byte  imagedescriptor
End Type
enum TGAERRORS
  err_ok   =0
  err_file
  err_format
  err_size
End enum

Function SaveTGA(Byval filename   As String        , _
                 Byval img        As fb.image Ptr=0, _
                 Byval targetbits As Integer     = 32) As Integer
  Dim As TGAHEADER   hdr
  Dim As Integer     l,w,h,b,p,hFile
  Dim As Byte Ptr    lpPixels

  If Len(filename)=0 Then Return err_file
  ' file must be in 24 or 32 bits
  If targetbits<>24 And _
     targetbits<>32 Then
    Return err_format
  End If
  ' no screen or screenres active
  If screenptr=0     Then Return err_format
  ' must pixels be locked for reading?
  l=iif(img=0,1,0)
  If l Then
    ' get values from screen
    screeninfo w,h,,b,p
  Else
    ' get values from image
    w=img->width:h=img->height:b=img->bpp:p=img->pitch
  End If
  If b<4 Then Return err_format
  If w<1 Then Return err_format
  If h<1 Then Return err_format
  ' try to open a file with write access
  hFile=Freefile
  If Open(filename For Binary Access Write As #hFile) Then
    Return err_file
  End If
  ' build header for uncompressed TGA
  With hdr
    .datatypecode   =2   ' RGB
    .width          =w   ' size x
    .height         =h   ' size y
    .bitsperpixel   =targetbits
  End With
  Put #hFile,,hdr ' write TGA header
  If l Then
    ScreenLock
    lpPixels=ScreenPtr ' first tripel in first row
  Else
    lpPixels=cptr(Byte Ptr,img)
    lpPixels+=32 ' first tripel in first row
  End If
  w Shl=2 ' width in bytes
  If targetbits=32 Then ' 32 bits save row by row
    While h
      Put #hFile,,*lpPixels,w ' width in pixels
      lpPixels+=p '+ pitch in bytes = one row
      h-=1
    Wend
  Else ' 24 bits save r,g,b row by row
    While h
      For x As Integer=0 To w-4 Step 4
        Put #hFile,,lpPixels[x+0] ' red
        Put #hFile,,lpPixels[x+1] ' green
        Put #hFile,,lpPixels[x+2] ' blue
      Next
      lpPixels+=p '+ pitch in bytes = one row
      h-=1
    Wend
  End If
  ' close the file
  Close hFile
  ' must be unlocked?
  If l Then ScreenUnlock
  Return err_ok
End Function

screenres 640,480,24 ' or 32
Dim As FB.image Ptr test=imagecreate(320,200,0)
Circle test,(160,100),50,rgb(&HFF,    0,   0)      ' red
Circle test,(160,100),49,rgb(   0,    0,&HFF),,,,F ' blue
Circle      (320,240),50,rgb(   0,&HFF,    0)      ' green
Circle      (320,240),49,rgb(&HFF,&HFF,    0),,,,F ' yellow

If SaveTGA("screen32.tga")        Then' save the whole screen as 32bit tga
  Beep:? "error screen32.tga"
End If
if SaveTGA("image32.tga",test)    Then' save the image as 32bit tga
  Beep:? "error image32.tga"
End If
if SaveTGA("screen24.tga",,24)    Then' save the whole screen as 24bit tga
  Beep:? "error screen24.tga"
End If
if SaveTGA("image24.tga",test,24) Then' save the image as 24bit tga
  Beep:? "error image24.tga"
End If
Sleep 1000
imagedestroy test
End

Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 14.09.2007 von Mitgliedcsde_rats angelegt.
  • Die aktuellste Version wurde am 23.09.2007 von Mitgliedcsde_rats gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen