Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
BMPToFunction
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 06.03.2010 03:02:24 |
/'
BMPToFunction:
Liest eine BMP ein und speichert sie als schnell einzufuegende Funktion.
BMPToFunction (BMPFile,FunctionName)
BMPFile ist ein String der den Namen der Bitmap enthaelt
FunctionName ist ein Optionaler String der den Namen der Funktion enthaelt
Hinweis:
Funktioniert ausschliesslich mit 32bit Farbtiefe
Example:
Screen 18,32 'Screen Initialisieren (Hinweis beachten)
BMPToFunction ("MeinBild.bmp","Bild")
'/
Declare Sub BMPToFunction (Byval BMPFileName as String, Byval FunctionName as String="")
Declare Function StrReplace (Byval StrEx as String, Byval StrMask as String, Byval StrRplce as String) as String
Declare Function BaseColor (Byval Image as any ptr) as UInteger
/'
"-------------------------------------------------------------------------------"
'/
Function StrReplace (Byval StrEx as String, Byval StrMask as String, Byval StrRplce as String) as String
If Len(StrEx)=0 or Len(StrMask)>Len(StrEx) Then Return StrEx
Dim Buffer as String=StrEx
Dim MaskSearch as UInteger
Dim MFound as byte
Dim lp as UInteger=1
Do
MaskSearch=InStr(lp,Buffer,StrMask)
MFound=0
If MaskSearch Then
MFound=1:lp=MaskSearch+Len(StrRplce)
Buffer=Left(Buffer,MaskSearch-1)+StrRplce+Right(Buffer,Len(Buffer)-(MaskSearch+(Len(StrMask)-1)))
End If
Loop while MFound=1
Return Buffer
End Function
/'
"-------------------------------------------------------------------------------"
'/
/'
"-------------------------------------------------------------------------------"
'/
Type BaseColorCount
RGBColor as UInteger
ColorCount as UInteger
End Type
Private Function BaseColor (Byval Image as any ptr) as UInteger
If Image=0 Then Return 0
Dim ImageVersion as UInteger=Peek(UInteger,Image)
If ImageVersion <> &h07 Then Return 0
Dim ImageBPP as UInteger=Peek(UInteger,Image+4)
If ImageBPP < &h04 Then Return 0
Dim ImageWidth as UInteger=Peek(UInteger,Image+8)
Dim ImageHeight as UInteger=Peek(UInteger,Image+12)
Dim ImagePitch as UInteger=Peek(UInteger,Image+16)
'-------------------------------------------------'
Dim ImageRGBBitList as UByte PTR=Callocate(2097152)
Dim ImageColorList as BaseColorCount PTR=Callocate((ImageWidth*ImageHeight)*Len(BaseColorCount))
Dim ImageColorCount as UInteger
Dim BitListByte as Integer
Dim BitListBit as Integer
Dim ReadColor as UInteger
For Y as UInteger=0 to ImageHeight-1
For X as UInteger=0 to ImageWidth-1
ReadColor=Peek(UInteger,Image+32+(X*4)+(Y*ImagePitch)) and &hFFFFFF
BitListByte=Fix(ReadColor/8)
BitListBit=ReadColor mod 8
If Bit(ImageRGBBitList[BitListByte],BitListBit)=0 Then
ImageRGBBitList[BitListByte]+=(1 shl BitListBit)
ImageColorList[ImageColorCount].RGBColor=(&hFF SHL 24)+ReadColor
ImageColorList[ImageColorCount].ColorCount=1
ImageColorCount+=1
Else
For C as UInteger=0 to ImageColorCount-1
If (ImageColorList[C].RGBColor and &hFFFFFF)=ReadColor Then
ImageColorList[C].ColorCount+=1
Exit For
End If
Next C
End If
Next X
Next Y
'-------------------------------------------------'
Deallocate ImageRGBBitList
Dim CB as UInteger
Dim CC as UInteger
For C as UInteger=0 to ImageColorCount-1
If ImageColorList[C].ColorCount>CC Then
CC=ImageColorList[C].ColorCount
CB=ImageColorList[C].RGBColor
End If
Next C
Deallocate ImageColorList
Return CB
End Function
/'
"-------------------------------------------------------------------------------"
'/
/'
"-------------------------------------------------------------------------------"
'/
Public Sub BMPToFunction (Byval BMPFileName as String, Byval FunctionName as String="")
If Dir(BMPFilename)="" Then Exit Sub
DIM F AS INTEGER=FREEFILE
Dim BMPHeader as String*2
Dim SizeX as UInteger
Dim SizeY as UInteger
OPEN BMPFileName FOR BINARY ACCESS READ AS #F
GET #F, , BMPHeader
If BMPHeader<>"BM" Then
Close #F
Exit Sub
End If
GET #F, 19, SizeX
GET #F, , SizeY
Close #F
?"Start"
Dim BMPImage as any ptr=ImageCreate(SizeX,SizeY)
BLoad BMPFileName,BMPImage
?"Search BaseColor"
Dim BMPBaseColor as UInteger=BaseColor(BMPImage)
?"BaseColor is Hex:"+Hex(BMPBaseColor,8)
Dim ReadColor as UInteger
Dim IMG_width as UInteger=Peek(UInteger,BMPImage+8)
Dim IMG_height as UInteger=Peek(UInteger,BMPImage+12)
Dim IMG_Pitch as UInteger=Peek(UInteger,BMPImage+16)
Dim APos as UInteger
If Trim(FunctionName)="" Then FunctionName=BMPFileName
FunctionName=STRReplace(FunctionName,".","_")
Open FunctionName+".txt" for output as #F
Print #F,"/"+chr(39)
Print #F,chr(34)+"-------------------------------------------------------------------------------"+chr(34)
Print #F,FunctionName
Print #F,chr(39)+"/"
Print #F,"Function "+FunctionName+" as any ptr"
Print #F," Dim IMGBuffer as UInteger PTR=ImageCreate("+str(IMG_width)+","+str(IMG_height)+",&h"+hex(BMPBaseColor,8)+")"
for y as integer=0 to IMG_height-1
for x as integer=0 to IMG_width-1
APos=X+(Y*(IMG_Pitch/4))+8
ReadColor=Peek(UInteger,BMPImage+32+(X*4)+(Y*IMG_Pitch))
If ReadColor<>BMPBaseColor Then
Print #F," IMGBuffer["+Str(APos)+"]=&h"+hex(ReadColor,8)
End If
next x
next y
Print #F," Return IMGBuffer"
Print #F,"/"+chr(39)
Print #F,chr(34)+"---"+chr(34,32)+FunctionName+chr(32,34)+"---"+chr(34)
Print #F,chr(39)+"/"
Print #F,"End Function"
Print #F,"/"+chr(39)
Print #F,chr(34)+"-------------------------------------------------------------------------------"+chr(34)
Print #F,chr(39)+"/"
Close #F
?"Ready."
?"Function saved as "+FunctionName+".txt"
End Sub
/'
"-------------------------------------------------------------------------------"
'/