Hey Everyone, sorry it's been too long and I've kept wanting to work on this further and have not had the chance...
So anyway, reluctantly here is the code so far with my improvements/modifications. You will see GIF's are better but still not perfect!
(I think this is the most up to date file, I'll verify this later tonight sometime but im about 98% positive)... I'll continue working on this sometime soon, if anyone has any fix's please let me know and I will implement them into the code to release an updated package. (I will be making a google-code page soon with some small utilities showing how to use this code and also the code itself so we can all maintain it and get it working good!)
Code: Select all
; PureGif Library for PureBasic (By Dean Williams)
; Original Code By: localmotion34 (Purebasic.fr forums)
; Updated & Extended By: Dean Williams - resplace.net
; Please help development and report any problems or improvements/bug fixes you may have
; if we all work together we can have some really nice GIF support in PureBasic!
; Thanks to the original author for his work and I hope my improvements go a long way
; towards getting this to work correctly!
;- Structures
Structure ANGIF
numberframes.l
framenumber.l
hBitmap.l[300]
EndStructure
Structure GIFHEADER ;Header
ghSig.b[6] ;Signature & Version
ghWidth.w ;Logical Screen Width
ghHeight.w ;Logical Screen Height
ghPkFields.b ;Global Color Table Flag
ghBkColIndex.b ;Background Color Index
ghAspRatio.b ;Pixel Aspect Ratio
EndStructure
Structure GIFIMAGE ;Image Descriptor
imSep.b ;Image Separator
imLeft.w ;Image Left Position
imTop.w ;Image Top Position
imWidth.w ;Image Width
imHeight.w ;Image Height
impkFields.b ;Local Color Table Flag
EndStructure
Structure GIFCLASS ;This is instead of using globals
*lpBytes.Byte ;Pointer to next byte in block
Pass.l ;First pass for interlaced images in OutLineGIF()
Line.l ;Offset for addressing the bits in OutLineGIF()
lpBits.l ;Scanline for bits
pitch.l ;Bytes are rounded up for image lines
CurrCodeSize.l ;The current code size
BitsLeft.l ;Used in NextCodeGIF()
BytesLeft.l ;Used in NextCodeGIF()
CurrByte.l ;Current byte
bUseGlobalColMap.b ;Is the color table global
GlobColRes.l ;Color Resolution, bits '6' '5' '4'
bImInterLace.b ;Is the image interlaced
ImgColRes.l ;Color Resolution
EndStructure
Procedure OutLineGIF(lpPixels.l,LineLen.l,height.l,*cl.GIFCLASS)
;Outputs the pixel color index data to the DIB
;lpPixels -> Memory block that holds the color index value
;LineLen -> Length of the line of pixels
;Height -> im\imHeight
;Gif images are 2, 16 or 256 colors, poking the values into memory
;requires a different method for each case. If gif is interlaced,
;that is dealt with here.
Protected ib.l,pixel.l,byte.l,BitCnt.l,CntBk.l,ColRes.l,Bits.l
Bits=*cl\lpBits-(*cl\Line * *cl\pitch) ;Pointer to bits
If *cl\bUseGlobalColMap
ColRes=*cl\GlobColRes
Else
ColRes=*cl\ImgColRes
EndIf
Select ColRes
Case 1
byte=0
For pixel=0 To LineLen-1 Step 8
ib=0
CntBk=7
For BitCnt=0 To 8-1
If PeekB(lpPixels+BitCnt+pixel)
ib=ib | (1 << CntBk)
EndIf
CntBk-1
Next
PokeB(Bits+byte,ib)
byte+1
Next
Case 4
byte=0
For pixel=0 To LineLen-1 Step 2
ib=((PeekB(lpPixels+pixel) & 255) << 4)
ib | (PeekB(lpPixels+pixel+1) & 255)
PokeB(Bits+byte,ib)
byte+1
Next
Case 8
For pixel=0 To LineLen-1
ib=PeekB(lpPixels+pixel) & 255
PokeB(Bits+pixel,ib)
Next
EndSelect
If *cl\bImInterLace ;Set Line for different passes when Interlaced
Select *cl\Pass
Case 0 ;Pass 1
If *cl\Line<height-8
*cl\Line+8
Else
*cl\Line=4 : *cl\Pass+1 ;Set Line for second pass
EndIf
Case 1 ;Pass 2
If *cl\Line<height-8
*cl\Line+8
Else
*cl\Line=2 : *cl\Pass+1 ;Set Line for third pass
EndIf
Case 2 ;Pass 3
If *cl\Line<height-4
*cl\Line+4
Else
*cl\Line=1 : *cl\Pass+1 ;Set Line for fourth pass
EndIf
Case 3 ;Pass 4
If *cl\Line<height-2
*cl\Line+2
EndIf
EndSelect
Else ;When not Interlaced increment Line
*cl\Line+1
EndIf
EndProcedure
#PB_LoadGifFIle=$6000
Procedure.l NextCodeGIF(file.l,Array CharBuff.b(1),Array CodeMask.l(1),*cl.GIFCLASS)
;Reads the next code from the data stream
;Returns the LZW CODE or ERROR
Protected count.l,Char.l,ret.l
If *cl\BitsLeft=0 ;Any bits left in byte?
If *cl\BytesLeft<=0 ;If not get another block
*cl\lpBytes=@CharBuff(0) ;Set byte pointer
*cl\BytesLeft=ReadByte(file) & 255
If *cl\BytesLeft<0
ProcedureReturn *cl\BytesLeft ;Return if error
ElseIf *cl\BytesLeft
For count=0 To *cl\BytesLeft-1
Char=ReadByte(file) & 255
If Char<0 : ProcedureReturn Char : EndIf
CharBuff(count)=Char ;Fill the char buffer with the new block
Next
EndIf
EndIf
*cl\CurrByte=*cl\lpBytes\b & 255 ;Get a byte
*cl\lpBytes+1 ;Increment index pointer
*cl\BitsLeft=8 ;Set bits left in the byte
*cl\BytesLeft-1 ;Decrement the bytes left counter
EndIf
;Shift off any previously used bits
ret=*cl\CurrByte >> (8-*cl\BitsLeft)
While *cl\CurrCodeSize>*cl\BitsLeft
If *cl\BytesLeft<=0
;Out of bytes in current block
*cl\lpBytes=@CharBuff(0) ;Set byte pointer
*cl\BytesLeft=ReadByte(file) & 255
If *cl\BytesLeft<0
ProcedureReturn *cl\BytesLeft ;Return if error
ElseIf *cl\BytesLeft
For count=0 To *cl\BytesLeft-1
Char=ReadByte(file) & 255
If Char<0 : ProcedureReturn Char : EndIf
CharBuff(count)=Char ;Fill the char buffer with the current block
Next
EndIf
EndIf
*cl\CurrByte=*cl\lpBytes\b & 255 ;Get a byte
*cl\lpBytes+1 ;Increment index pointer
ret | (*cl\CurrByte << *cl\BitsLeft) ;Add remaining bits to return
*cl\BitsLeft+8 ;Set bit counter
*cl\BytesLeft-1 ;Decrement bytesleft counter
Wend
*cl\BitsLeft-*cl\CurrCodeSize ;Subtract the code size from bitsleft
ret & CodeMask(*cl\CurrCodeSize) ;Mask off the right number of bits
ProcedureReturn ret
EndProcedure
Procedure DrawTransparentImage(DC, bitmap, x, y, width, height, TransparentColor)
; First, create some DC's. These are our gateways To associated
; bitmaps in RAM
maskDC = CreateCompatibleDC_(DC)
tempDC = CreateCompatibleDC_(DC)
SourceDC = CreateCompatibleDC_(DC)
SelectObject_(SourceDC, bitmap)
; Then, we need the bitmaps. Note that we create a monochrome
; bitmap here!
; This is a trick we use For creating a mask fast enough.
hMaskBmp = CreateBitmap_(width, height, 1, 1, 0)
hTempBmp = CreateCompatibleBitmap_(DC, width, height)
; Then we can assign the bitmaps to the DCs
;
hMaskBmp = SelectObject_(maskDC, hMaskBmp)
hTempBmp = SelectObject_(tempDC, hTempBmp)
; Now we can create a mask. First, we set the background color
; To the transparent color; then we copy the image into the
; monochrome bitmap.
; When we are done, we reset the background color of the
; original source.
TransparentColor= SetBkColor_(SourceDC, TransparentColor)
BitBlt_ (maskDC, 0, 0, width, height, SourceDC, 0, 0, #SRCCOPY)
SetBkColor_(SourceDC, TransparentColor)
; The first we do with the mask is To MergePaint it into the
; destination.
; This will punch a WHITE hole in the background exactly were
; we want the graphics To be painted in.
BitBlt_ (tempDC, 0, 0, width, height, maskDC, 0, 0, #SRCCOPY)
BitBlt_ (DC, x, y, width, height, tempDC, 0, 0, #MERGEPAINT)
; Now we delete the transparent part of our source image. To do
; this, we must invert the mask And MergePaint it into the
; source image. The transparent area will now appear as WHITE.
BitBlt_ (maskDC, 0, 0, width, height, maskDC, 0, 0, #NOTSRCCOPY)
BitBlt_ (tempDC, 0, 0, width, height, SourceDC, 0, 0, #SRCCOPY)
BitBlt_ (tempDC, 0, 0, width, height, maskDC, 0, 0, #MERGEPAINT)
; Both target And source are clean. All we have To do is To And
; them together!
BitBlt_ (DC, x, y, width, height, tempDC, 0, 0, #SRCAND)
; Now all we have To do is To clean up after us And free system
; resources..
DeleteObject_ (hMaskBmp)
DeleteObject_ (hTempBmp)
DeleteDC_ (maskDC)
DeleteDC_ (tempDC)
DeleteDC_ (SourceDC)
EndProcedure
Procedure.l LoadGIFframes(filename.s,Array imageArray.l(1))
;From "loadgif.c" for ImageShop32 by John Findlay
;Loads LZW Graphics Interchange Format files
;Uses NextCodeGIF() and OutLineGIF()
Protected Dim stack.b(4096) ;Stack for storing pixels
Protected Dim suffix.b(4096) ;Suffix table, max number of LZW codes
Protected Dim prefix.l(4096) ;Prefix linked list (these are longs)
Protected Dim CharBuff.b(279) ;Current block
Protected Dim GlobalCols.l(256) ;Global colors of gif
Protected Dim localCols.l(256) ;Local image colors of gif
Protected Dim CodeMask.l(16) ;Masks for LZW compression algorithm
Protected gh.GIFHEADER
Protected im.GIFIMAGE
Protected cl.GIFCLASS
Protected bi.BITMAPINFOHEADER
Protected *pal.RGBQUAD
Protected *lpSP.Byte ;Pointer to stack
Protected *lpBuffPtr.Byte ;Pointer to buffer
Protected bGlobColsSorted.b ;Sort Flag bit '3' (this is unused)
Protected file.l,sig.s,PkFields.l,bGlobColTable.b,GlobColBytes.l
Protected GlobColors.l,count.l,Red.l,Green.l,Blue.l
Protected width.l,height.l,impkFields.l,bImColsSorted.b
Protected bImColTable.b,ImgColBytes.l,LZWCodeSize.l,TopSlot.l
Protected ClearCode.l,ImgColors.l,EndingCode.l,NewCodes.l,Slot.l
Protected lpBUFF.l,TempOldCode.l,OldCode.l,BufCnt.l,bitcount.l
Protected ncolors.l,Len.l,hDIB.l,cc.l,code.l
Protected *dib.BITMAPINFOHEADER
CodeMask( 0)=$0000 : CodeMask( 1)=$0001
CodeMask( 2)=$0003 : CodeMask( 3)=$0007
CodeMask( 4)=$000F : CodeMask( 5)=$001F
CodeMask( 6)=$003F : CodeMask( 7)=$007F
CodeMask( 8)=$00FF : CodeMask( 9)=$01FF
CodeMask(10)=$03FF : CodeMask(11)=$07FF
CodeMask(12)=$0FFF : CodeMask(13)=$1FFF
CodeMask(14)=$3FFF : CodeMask(15)=$7FFF
;Open the file
file=ReadFile(#PB_Any,filename)
If file=0
;LogError("GIF Load Error!" , "Could not open the GIF image file for reading." , "File Path = " + filename)
ProcedureReturn #False
EndIf
;Read the file header and logical screen descriptor
ReadData(file,gh,SizeOf(gh))
sig=PeekS(@gh\ghSig,6) ;Get the header version string
If sig<>"GIF89a" And sig<>"GIF87a"
CloseFile(file)
;LogError("GIF Load Error!" , "File was not a valid GIF image file" , "File Path = " + filename + Chr(23) + "File Signature = " + sig)
ProcedureReturn #False ;NOT_VALID
EndIf
realwidth=gh\ghWidth
realheight=gh\ghHeight
;Store gh\ghPkFields for bit manipulation
PkFields=gh\ghPkFields & 255
;Global Color Table Flag bit '7'
bGlobColTable=(PkFields & (1 << 7)) >> 7
If bGlobColTable
cl\bUseGlobalColMap=#True
GlobColBytes=3*(1 << ((PkFields & $07)+1)) ;Table size in bytes
GlobColors=GlobColBytes/3 ;Number of colors
;Some gif encoders do not follow the gif spec very well,
;so make cl\GlobColRes from GlobColors.
;Also gif's are used on different platforms, which do
;have different bits per pixel. i.e. 32 colors is 5 bits/pixel.
If GlobColors<=2
cl\GlobColRes=1
ElseIf GlobColors<=16
cl\GlobColRes=4
Else
cl\GlobColRes=8
EndIf
For count=0 To GlobColors-1 ;Get the global screen colors
Red=ReadByte(file) & 255
Green=ReadByte(file) & 255
Blue=ReadByte(file) & 255
GlobalCols(count)=RGB(Red,Green,Blue)
Next
EndIf
Debug "Image!"
count=0
While count<>$2C ;Search for im\imSep
count=ReadByte(file) & 255
If count = $F9
ReadByte(file)
trans = ReadByte(file) & 1
Debug "MTrans: " + Str(trans)
ReadWord(file)
TByte = ReadByte(file)
Debug "TByte: " + Str(TByte)
If TByte >0 And TByte <255
transcolor = GlobalCols(TByte)
Debug "MTransCol: " + Str(trans)
Else
;Disable transparency, we dont have a correct color
trans=0
transcolor=0
EndIf
EndIf
Wend
FileSeek(file,Loc(file)-1) ;Seek to im\imSep
ReadData(file,im,SizeOf(im)) ;Read the image descriptor
;Store im\imPkFields for bit manipulation
impkFields=im\impkFields & 255
;Is the image interlaced
cl\bImInterLace=(impkFields & (1 << 6)) >> 6
;Is the local color table sorted
bImColsSorted=(impkFields & (1 << 5)) >> 5
;Is there a local color table
bImColTable=(impkFields & (1 << 7)) >> 7
If bImColTable
cl\bUseGlobalColMap=#False
ImgColBytes=3*(1 << ((impkFields & $07)+1)) ;Table size in bytes
ImgColors=ImgColBytes/3 ;Number of colors
If ImgColors<=2 ;Make sure image bit depth is 1, 4 or 8
cl\ImgColRes=1
ElseIf ImgColors<=16
cl\ImgColRes=4
Else
cl\ImgColRes=8
EndIf
For count=0 To ImgColors-1 ;Get the local image colors
Red=ReadByte(file) & 255
Green=ReadByte(file) & 255
Blue=ReadByte(file) & 255
localCols(count)=RGB(Red,Green,Blue)
Next
transcolor=LocalCols(TByte)
Else ;No local color table
If cl\bUseGlobalColMap=#False ;No global color table
CloseFile(file)
;LogError("GIF Load Error!" , "The GIF image does not contain a valid color table." , "")
ProcedureReturn #False ;NO_COLORTABLE
EndIf
EndIf
width=im\imWidth & $FFFF ;Image width
height=im\imHeight & $FFFF ;Image height
;Get the first byte of the new block of image data.
;Should be the bit size
LZWCodeSize=ReadByte(file) & 255
;Bit size is normally the same as the color resolution.
;i.e. 8 for 256 colors
If LZWCodeSize<2 Or LZWCodeSize>8
CloseFile(file)
;LogError("GIF Load Error!" , "LZW code size is not valid!" , "LZW code size = "+ Str(LZWCodeSize))
ProcedureReturn #False ;BAD_CODE_SIZE
EndIf
;Initialise the variables for the decoder for reading a new image.
cl\CurrCodeSize=LZWCodeSize+1
TopSlot=1 << cl\CurrCodeSize ;Highest code for current size
ClearCode=1 << LZWCodeSize ;Value for a clear code
EndingCode=ClearCode+1 ;Value for an ending code
NewCodes=ClearCode+2 ;First available code
Slot=NewCodes ;Last read code
cl\BitsLeft=0
cl\BytesLeft=0
;Just in case...
TempOldCode=0 : OldCode=0
;Allocate space for the decode buffer
lpBUFF=AllocateMemory(width+8) ;+8 just in case
;Set up the stack pointer, decode buffer pointer and line counter
*lpSP=@stack(0)
*lpBuffPtr=lpBUFF
BufCnt=width ;Count for pixel line length
;Start creating the DIB
If cl\bUseGlobalColMap ;Global color table
bitcount=cl\GlobColRes
Else ;Local color table
bitcount=cl\ImgColRes
EndIf
bi\biSize=SizeOf(bi)
bi\biWidth=width
bi\biHeight=height
bi\biPlanes=1
bi\biBitCount=bitcount ;BitCount will be 1, 4 or 8
bi\biCompression=#BI_RGB
bi\biSizeImage=0
bi\biXPelsPerMeter=0
bi\biYPelsPerMeter=0
If cl\bUseGlobalColMap ;Global color table
bi\biClrUsed=GlobColors
Else ;Local color table
bi\biClrUsed=ImgColors
EndIf
bi\biClrImportant=0
;With the BITMAPINFO format headers, the size of the palette is
;in biClrUsed, whereas in the BITMAPCORE - style headers, it is
;dependent on the Bits per pixel (2 to the power of bitsperpixel).
If bi\biClrUsed<>0
ncolors=bi\biClrUsed
Else ;We don't have an optimal palette
ncolors=1 << bi\biBitCount
EndIf
cl\pitch=(((bitcount*width)+31) >> 5) << 2 ;Bytes per line
Len=bi\biSize+(ncolors*4)+(cl\pitch*height) ;Size of DIB
bi\biSizeImage=cl\pitch*height ;Fill in biSizeImage
;Allocate memory block to store our DIB
hDIB=AllocateMemory(Len)
If hDIB=0
FreeMemory(lpBUFF)
;CloseFile(file)
;LogError("GIF Load Error!" , "Memory allocation failed!" , "")
ProcedureReturn #False ;NO_DIB
EndIf
;Fill first part of DIB with the BITMAPINFOHEADER
CopyMemory(bi,hDIB,SizeOf(bi))
;Set the colors in the DIB (or masks for the new DIB formats)
*pal=hDIB+SizeOf(bi)
If cl\bUseGlobalColMap
For count=0 To bi\biClrUsed-1
*pal\rgbBlue=Blue(GlobalCols(count))
*pal\rgbGreen=Green(GlobalCols(count))
*pal\rgbRed=Red(GlobalCols(count))
*pal+4
Next
Else
For count=0 To bi\biClrUsed-1
*pal\rgbBlue=Blue(localCols(count))
*pal\rgbGreen=Green(localCols(count))
*pal\rgbRed=Red(localCols(count))
*pal+4
Next
EndIf
cl\Line=0 ;Set address offset for OutLineGIF()
cl\Pass=0 ;For interlaced images in OutLineGIF()
;Image data bits of DIB
cl\lpBits=hDIB+bi\biSize+(ncolors*4)+(cl\pitch*(height-1))
;This is the main loop. For each code we get we pass through the
;linked list of prefix codes, pushing the corresponding "character"
;for each code onto the stack. When the list reaches a single
;"character" we push that on the stack too, and then start
;unstacking each character for output in the correct order.
;Special handling is included for the clear code, and the whole
;thing ends when we get an ending code.
While cc<>EndingCode
cc=NextCodeGIF(file,CharBuff(),CodeMask(),cl)
If cc<0 ;If a file error, return without completing the decode
FreeMemory(lpBUFF)
;CloseFile(file)
;LogError("GIF Load Error!" , "LZW code size is not valid!" , "LZW code size = "+ Str(cc))
ProcedureReturn #False ;FILE_ERROR
EndIf
;If the code is a clear code, re-initialise all necessary items.
If cc=ClearCode
cl\CurrCodeSize=LZWCodeSize+1
Slot=NewCodes
TopSlot=1 << cl\CurrCodeSize
;Continue reading codes until we get a non-clear code
;(another unlikely, but possible case...)
While cc=ClearCode
cc=NextCodeGIF(file,CharBuff(),CodeMask(),cl)
Wend
;If we get an ending code immediately after a clear code
;(yet another unlikely case), then break out of the loop.
If cc=EndingCode
Break ;end loop
EndIf
;Finally, if the code is beyond the range of already set codes,
;(This one had better not happen, I have no idea what will
;result from this, but I doubt it will look good)
;then set it to color zero.
If cc>=Slot
cc=0
EndIf
OldCode=cc
TempOldCode=OldCode
;And let us not forget to put the char into the buffer, and if,
;on the off chance, we were exactly one pixel from the end of
;the line, we have to send the buffer to the OutLineGIF() routine
*lpBuffPtr\b=cc
*lpBuffPtr+1
BufCnt-1
If BufCnt=0
OutLineGIF(lpBUFF,width,height,cl)
*lpBuffPtr=lpBUFF
BufCnt=width
EndIf
Else
;In this case, it's not a clear code or an ending code, so it
;must be a code code. So we can now decode the code into a
;stack of character codes (Clear as mud, right?).
code=cc
If code=Slot
code=TempOldCode
*lpSP\b=OldCode
*lpSP+1
EndIf
;Here we scan back along the linked list of prefixes, pushing
;helpless characters (i.e. suffixes) onto the stack as we do so.
While code>=NewCodes
*lpSP\b=suffix(code)
*lpSP+1
code=prefix(code)
Wend
;Push the last character on the stack, and set up the new
;prefix and suffix, and if the required slot number is greater
;than that allowed by the current bit size, increase the bit
;size. (Note - if we are all full, we *don't* save the new
;suffix and prefix. I'm not certain if this is correct,
;it might be more proper to overwrite the last code.
*lpSP\b=code
*lpSP+1
If Slot<TopSlot
OldCode=code
suffix(Slot)=OldCode
prefix(Slot)=TempOldCode
Slot+1
TempOldCode=cc
EndIf
If Slot>=TopSlot
If cl\CurrCodeSize<12
TopSlot=TopSlot << 1
cl\CurrCodeSize+1
EndIf
EndIf
;Now that we've pushed the decoded string (in reverse order)
;onto the stack, lets pop it off and put it into our decode
;buffer, and when the decode buffer is full, write another line.
While *lpSP>@stack(0)
*lpSP-1
*lpBuffPtr\b=*lpSP\b
*lpBuffPtr+1
BufCnt-1
If BufCnt=0
OutLineGIF(lpBUFF,width,height,cl)
*lpBuffPtr=lpBUFF
BufCnt=width
EndIf
Wend
EndIf
Wend
If BufCnt<>width ;If there are any left, output the bytes
OutLineGIF(lpBUFF,width-BufCnt-1,height,cl)
EndIf
*dib=hDIB
If *dib=0 ;Avoid errors
ProcedureReturn #False
EndIf
Bits=*dib+*dib\biSize+(*dib\biClrUsed*4) ;Pointer to bits
;Create the DDB bitmap
hdc=GetDC_(#Null)
hBitmap=CreateDIBitmap_(hdc,*dib,#CBM_INIT,Bits,*dib,#DIB_RGB_COLORS)
pbimage=CreateImage(#PB_Any,realwidth,realheight)
drawdc=StartDrawing(ImageOutput(pbimage))
Box(0,0,realwidth,realheight,$FFFFFF)
If trans=1
DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,transcolor)
Else
DrawImage(hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight)
EndIf
StopDrawing()
FreeMemory(hDIB)
imageArray(0)=ImageID(pbimage) ;hBitmap
numberimages=1
;- continue to other frames
Macro GetBit(Value, bit)
(Value&(1<<bit))>>bit ;Translates as 'value' ANDed with 2^bit and shifted back to bitposition 0
EndMacro
; Read through the various image blocks
NotatEnd=1
While NotatEnd=1
While n<>$2C
n=ReadByte(file) & 255
If n=$3B
NotatEnd=0
CloseFile(file)
FreeMemory(lpBUFF)
ProcedureReturn numberimages
ElseIf n=$F9
;Graphics control extension
n=ReadByte(file) & 255
Size=n
n=ReadByte(file) ;& 255
packedfields.b=n &$FF
;Debug Bin(n&$FF)
disposalmethod= (n & %00011100) >>2
;Debug disposalmethod
tflag= GetBit(n,0) ;n& %00000001
;Debug tflag
delaytime.w=ReadWord(file)
;Debug delaytime & $FFFF
transparent.b=ReadByte(file)
ElseIf n=$FF
;application extension
ElseIf n=$FE
;comment extention
n=ReadByte(file) & 255
FileSeek(file,Loc(file)+n)
ElseIf n= $01
;"plain text extention"
Debug "text"
; n=ReadByte(file) & 255
;FileSeek(file,Loc(file)+n& $FF)
ElseIf n =$21
;"A Extension_block
EndIf
Wend
n=0
; done with reading the image blocks for this frame
FileSeek(file,Loc(file)-1)
count=0
While count<>$2C ;Search for im\imSep
count=ReadByte(file) & 255
Wend
FileSeek(file,Loc(file)-1) ;Seek to im\imSep
ReadData(file,im,SizeOf(im)) ;Read the image descriptor
;Store im\imPkFields for bit manipulation
impkFields=im\impkFields & 255
;Is the image interlaced
cl\bImInterLace=(impkFields & (1 << 6)) >> 6
;Is the local color table sorted
bImColsSorted=(impkFields & (1 << 5)) >> 5
;Is there a local color table
bImColTable=(impkFields & (1 << 7)) >> 7
If bImColTable
cl\bUseGlobalColMap=#False
ImgColBytes=3*(1 << ((impkFields & $07)+1)) ;Table size in bytes
ImgColors=ImgColBytes/3 ;Number of colors
If ImgColors<=2 ;Make sure image bit depth is 1, 4 or 8
cl\ImgColRes=1
ElseIf ImgColors<=16
cl\ImgColRes=4
Else
cl\ImgColRes=8
EndIf
For count=0 To ImgColors-1 ;Get the local image colors
Red=ReadByte(file) & 255
Green=ReadByte(file) & 255
Blue=ReadByte(file) & 255
localCols(count)=RGB(Red,Green,Blue)
Next
;loctranscolor=localCols(transparent& $FF)
transcolor=localCols(transparent& $FF)
Else ;No local color table
If cl\bUseGlobalColMap=#False ;No global color table
CloseFile(file)
;LogError("GIF Load Error!" , "The GIF image does not contain a valid color table." , "")
ProcedureReturn #False ;NO_COLORTABLE
EndIf
transcolor=GlobalCols(transparent& $FF)
EndIf
width=im\imWidth & $FFFF ;Image width
height=im\imHeight & $FFFF ;Image height
;Get the first byte of the new block of image data.
;Should be the bit size
LZWCodeSize=ReadByte(file) & 255
;Bit size is normally the same as the color resolution.
;i.e. 8 for 256 colors
If LZWCodeSize<2 Or LZWCodeSize>8
CloseFile(file)
;LogError("GIF Load Error!" , "LZW code size is not valid!" , "LZW code size = "+ Str(LZWCodeSize))
ProcedureReturn #False ;BAD_CODE_SIZE
EndIf
;Initialise the variables for the decoder for reading a new image.
cl\CurrCodeSize=LZWCodeSize+1
TopSlot=1 << cl\CurrCodeSize ;Highest code for current size
ClearCode=1 << LZWCodeSize ;Value for a clear code
EndingCode=ClearCode+1 ;Value for an ending code
NewCodes=ClearCode+2 ;First available code
Slot=NewCodes ;Last read code
cl\BitsLeft=0
cl\BytesLeft=0
;Just in case...
TempOldCode=0 : OldCode=0
;Allocate space for the decode buffer
lpBUFF=AllocateMemory(width+8) ;+8 just in case
;Set up the stack pointer, decode buffer pointer and line counter
*lpSP=@stack(0)
*lpBuffPtr=lpBUFF
BufCnt=width ;Count for pixel line length
;Start creating the DIB
If cl\bUseGlobalColMap ;Global color table
bitcount=cl\GlobColRes
Else ;Local color table
bitcount=cl\ImgColRes
EndIf
bi\biSize=SizeOf(bi)
bi\biWidth=width
bi\biHeight=height
bi\biPlanes=1
bi\biBitCount=bitcount ;BitCount will be 1, 4 or 8
bi\biCompression=#BI_RGB
bi\biSizeImage=0
bi\biXPelsPerMeter=0
bi\biYPelsPerMeter=0
If cl\bUseGlobalColMap ;Global color table
bi\biClrUsed=GlobColors
Else ;Local color table
bi\biClrUsed=ImgColors
EndIf
bi\biClrImportant=0
;With the BITMAPINFO format headers, the size of the palette is
;in biClrUsed, whereas in the BITMAPCORE - style headers, it is
;dependent on the Bits per pixel (2 to the power of bitsperpixel).
If bi\biClrUsed<>0
ncolors=bi\biClrUsed
Else ;We don't have an optimal palette
ncolors=1 << bi\biBitCount
EndIf
cl\pitch=(((bitcount*width)+31) >> 5) << 2 ;Bytes per line
Len=bi\biSize+(ncolors*4)+(cl\pitch*height) ;Size of DIB
bi\biSizeImage=cl\pitch*height ;Fill in biSizeImage
;Allocate memory block to store our DIB
hDIB=AllocateMemory(Len)
If hDIB=0
FreeMemory(lpBUFF)
CloseFile(file)
;LogError("GIF Load Error!" , "Memory allocation failed!" , "")
ProcedureReturn #False ;NO_DIB
EndIf
;Fill first part of DIB with the BITMAPINFOHEADER
CopyMemory(bi,hDIB,SizeOf(bi))
;Set the colors in the DIB (or masks for the new DIB formats)
*pal=hDIB+SizeOf(bi)
If cl\bUseGlobalColMap
For count=0 To bi\biClrUsed-1
*pal\rgbBlue=Blue(GlobalCols(count))
*pal\rgbGreen=Green(GlobalCols(count))
*pal\rgbRed=Red(GlobalCols(count))
*pal+4
Next
Else
For count=0 To bi\biClrUsed-1
*pal\rgbBlue=Blue(localCols(count))
*pal\rgbGreen=Green(localCols(count))
*pal\rgbRed=Red(localCols(count))
*pal+4
Next
EndIf
cl\Line=0 ;Set address offset for OutLineGIF()
cl\Pass=0 ;For interlaced images in OutLineGIF()
;Image data bits of DIB
cl\lpBits=hDIB+bi\biSize+(ncolors*4)+(cl\pitch*(height-1))
;This is the main loop. For each code we get we pass through the
;linked list of prefix codes, pushing the corresponding "character"
;for each code onto the stack. When the list reaches a single
;"character" we push that on the stack too, and then start
;unstacking each character for output in the correct order.
;Special handling is included for the clear code, and the whole
;thing ends when we get an ending code.
cc=0
While cc<>EndingCode
cc=NextCodeGIF(file,CharBuff(),CodeMask(),cl)
If cc<0 ;If a file error, return without completing the decode
FreeMemory(lpBUFF)
CloseFile(file)
;LogError("GIF Load Error!", "GIF image contained an in-valid LZW code." , "LZW Read = "+Str(cc))
ProcedureReturn #False ;FILE_ERROR
EndIf
;If the code is a clear code, re-initialise all necessary items.
If cc=ClearCode
cl\CurrCodeSize=LZWCodeSize+1
Slot=NewCodes
TopSlot=1 << cl\CurrCodeSize
;Continue reading codes until we get a non-clear code
;(another unlikely, but possible case...)
While cc=ClearCode
cc=NextCodeGIF(file,CharBuff(),CodeMask(),cl)
Wend
;If we get an ending code immediately after a clear code
;(yet another unlikely case), then break out of the loop.
If cc=EndingCode
Break ;end loop
EndIf
;Finally, if the code is beyond the range of already set codes,
;(This one had better not happen, I have no idea what will
;result from this, but I doubt it will look good)
;then set it to color zero.
If cc>=Slot
cc=0
EndIf
OldCode=cc
TempOldCode=OldCode
;And let us not forget to put the char into the buffer, and if,
;on the off chance, we were exactly one pixel from the end of
;the line, we have to send the buffer to the OutLineGIF() routine
*lpBuffPtr\b=cc
*lpBuffPtr+1
BufCnt-1
If BufCnt=0
OutLineGIF(lpBUFF,width,height,cl)
*lpBuffPtr=lpBUFF
BufCnt=width
EndIf
Else
;In this case, it's not a clear code or an ending code, so it
;must be a code code. So we can now decode the code into a
;stack of character codes (Clear as mud, right?).
code=cc
If code=Slot
code=TempOldCode
*lpSP\b=OldCode
*lpSP+1
EndIf
;Here we scan back along the linked list of prefixes, pushing
;helpless characters (i.e. suffixes) onto the stack as we do so.
While code>=NewCodes
*lpSP\b=suffix(code)
*lpSP+1
code=prefix(code)
Wend
;Push the last character on the stack, and set up the new
;prefix and suffix, and if the required slot number is greater
;than that allowed by the current bit size, increase the bit
;size. (Note - if we are all full, we *don't* save the new
;suffix and prefix. I'm not certain if this is correct,
;it might be more proper to overwrite the last code.
*lpSP\b=code
*lpSP+1
If Slot<TopSlot
OldCode=code
suffix(Slot)=OldCode
prefix(Slot)=TempOldCode
Slot+1
TempOldCode=cc
EndIf
If Slot>=TopSlot
If cl\CurrCodeSize<12
TopSlot=TopSlot << 1
cl\CurrCodeSize+1
EndIf
EndIf
;Now that we've pushed the decoded string (in reverse order)
;onto the stack, lets pop it off and put it into our decode
;buffer, and when the decode buffer is full, write another line.
While *lpSP>@stack(0)
*lpSP-1
*lpBuffPtr\b=*lpSP\b
*lpBuffPtr+1
BufCnt-1
If BufCnt=0
OutLineGIF(lpBUFF,width,height,cl)
*lpBuffPtr=lpBUFF
BufCnt=width
EndIf
Wend
EndIf
Wend
If BufCnt<>width ;If there are any left, output the bytes
OutLineGIF(lpBUFF,width-BufCnt-1,height,cl)
EndIf
;Create the DDB bitmap
*dib=hDIB
If *dib=0 ;Avoid errors
ProcedureReturn #False
EndIf
Bits=*dib+*dib\biSize+(*dib\biClrUsed*4) ;Pointer to bits
;- create the bitmap
;Create the DDB bitmap
hdc=GetDC_(#Null)
hBitmap=CreateDIBitmap_(hdc,*dib,#CBM_INIT,Bits,*dib,#DIB_RGB_COLORS)
pbimage=CreateImage(#PB_Any,realwidth,realheight)
drawdc=StartDrawing(ImageOutput(pbimage))
; For some retarded reason, we have to draw and redraw the GIF frames over the previous image imagenumber-1
Debug "TransFlag: "+Str(tflag)
; If bUseGlobalColMap ; if a local color table, then draw previous image in array, and then dray new hbitmap with transparency
; Box(0,0,realwidth,realheight,$FFFFFF)
; DrawImage(imageArray(numberimages-1),0,0)
; If tflag=1
; ;loc
; DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,transcolor)
; Else
; DrawImage(hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight)
; EndIf
; Else
Debug "Disposal: "+Str(disposalmethod)
If disposalmethod =1
Box(0,0,realwidth,realheight,$FFFFFF)
DrawImage(imageArray(numberimages-1),0,0)
If tflag=1
;glob
DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,transcolor)
Else
DrawImage(hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight)
EndIf
ElseIf disposalmethod =2
Box(0,0,realwidth,realheight,$FFFFFF)
;DrawImage(imageArray(0),0,0)
If tflag=1
;glob
DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,transcolor)
Else
DrawImage(hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight)
EndIf
Else
Box(0,0,realwidth,realheight,$FFFFFF)
;DrawImage(imageArray(numberimages-1),0,0)
;DrawImage(hBitmap,im\imLeft,im\imTop)
If tflag=1
;glob
DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,transcolor)
Else
DrawImage(hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight)
EndIf
EndIf
; EndIf
StopDrawing()
FreeMemory(hDIB) ;Free the DIB
imageArray(numberimages)=ImageID(pbimage)
numberimages=numberimages+1
Wend
ProcedureReturn numberimages
EndProcedure
;Procedure TimerProc(hwnd,
Procedure GIFTimerProc(hwnd,msg,wParam,lParam)
Select msg
Case #PB_LoadGifFIle
*GIFframe.ANGIF=GetProp_(hwnd,"frameinfo")
If *GIFframe
For d=0 To *GIFframe\numberframes-1
DeleteObject_(*GIFframe\hBitmap[d])
Next
FreeMemory(*GIFframe)
EndIf
*frame.ANGIF=AllocateMemory(SizeOf(ANGIF))
Dim GIFarray.l(600)
string.s=PeekS(lParam)
numberframes=LoadGIFframes(string.s,GIFarray())
If numberframes <1
;obviously a problem here :o
;LogError("GIF Load Error!" , "File was not a valid GIF image file, returned 0 frames!" , "Frames = " + Str(numberframes))
ProcedureReturn #False
EndIf
ReDim GIFarray.l(numberframes-1)
SendMessage_(hwnd,#STM_SETIMAGE,#IMAGE_BITMAP,GIFarray(0))
SetTimer_(hwnd,200,100,0)
*frame\numberframes=numberframes
*frame\framenumber=0
For a=0 To numberframes-1
*frame\hBitmap[a]=GIFarray(a)
Next
SetProp_(hwnd,"frameinfo",*frame.ANGIF)
Case #WM_TIMER
*GIFframe.ANGIF=GetProp_(hwnd,"frameinfo") ; get the image array pointer
framenumber=*GIFframe\framenumber ; get the frame index
KillTimer_(hwnd,200) ; stop the timer
*GIFframe\framenumber=*GIFframe\framenumber+1; increase the frame count
If *GIFframe\framenumber=*GIFframe\numberframes
*GIFframe\framenumber=0
EndIf
hBitmap=*GIFframe\hBitmap[framenumber] ; get the bitmap
;delaytime=PeekW(*ptr+(frame*SizeOf(ANGIF))+4) ; get the delaytime
SendMessage_(hwnd,#STM_SETIMAGE,#IMAGE_BITMAP,hBitmap); set the new bitmap
SetTimer_(hwnd,200,100,0) ; set the new timer
SetProp_(hwnd,"frameinfo",*GIFframe.ANGIF); reset the window props
;FreeMemory(*GIFframe)
EndSelect
ProcedureReturn CallWindowProc_(GetProp_(hwnd,"oldproc"),hwnd,msg,wParam,lParam)
EndProcedure
Procedure GifStaticControl(id.l,x.l,y.l,width.l,height.l)
StaticCtl=ImageGadget(id,x.l,y.l,width.l,height,0,#PB_Image_Border)
If id=#PB_Any
PBreturn=StaticCtl
hwnd=GadgetID(StaticCtl)
Else
PBreturn=GadgetID(id)
hwnd=GadgetID(id)
EndIf
SetProp_(hwnd,"oldproc",SetWindowLong_(hwnd,#GWL_WNDPROC,@GIFTimerProc())) ; subclass
ProcedureReturn PBreturn
EndProcedure
If OpenWindow(0, 0, 0, 800, 600, "MDIGadget", #PB_Window_SystemMenu|#PB_Window_ScreenCentered|#PB_Window_SizeGadget|#PB_Window_MaximizeGadget)
If CreateGadgetList(WindowID(0)) And CreateMenu(0, WindowID(0))
MenuTitle("File")
MenuItem(0, "Open GIF")
MenuItem(1, "Exit")
MenuTitle("MDI windows menu")
;MDIGadget(0, 0, 0, 0, 0, 1, 2, #PB_MDI_AutoSize)
;GifStaticControl(50,100,100,200,200)
EndIf
EndIf
Repeat
Select WaitWindowEvent()
Case #PB_Event_Gadget
Select EventGadget()
Case 0
EndSelect
Case #PB_Event_Menu
Select EventMenu()
Case 0
Pattern.s="All Supported Formats|*.gif"
filename.s=OpenFileRequester("Choose An Image File To Open","",Pattern,0)
If filename
;SendMessage_(GadgetID(50),#PB_LoadGifFIle,0,filename)
Dim myarray.l(800)
numberGIFs=LoadGIFframes(filename,myarray())
UseGadgetList(WindowID(0))
GifStaticControl(50,100,100,200,200)
For a=1 To numberGIFs
AddGadgetItem(50,a,"GIF Frame " + Str(a))
CreateGadgetList(WindowID(0))
ImageGadget(a*10,0,50*a,0,0,0)
SendMessage_(GadgetID(a*10),#STM_SETIMAGE,#IMAGE_BITMAP,myarray(a-1))
Next
EndIf
Case 1
End
EndSelect
Case #PB_Event_CloseWindow
End
EndSelect
ForEver
