Code : Tout sélectionner
;
; Animated GIF control
;
; I am not very happy with it, but this seems to be the best way to deal
; with the GIF control. The control uses window properties to store a
; structure that contains the number of frames, the current rendered frame,
; and all the bitmaps of the GIF stored in a static array.
; Currently, I have the maximum number of frames set to 600.
; I can see no way anyone would need more than 600 frames.
; I have a GIf created from ULEAD Cool3D that is 12 seconds long,
; and is 200 frames. it is 5 megs compressed as a GIF.
; Unless you REALLY want to push your CPU during load time, 600 is plenty.
;
;- Structures
Structure ANGIF
numberframes.l
framenumber.l
hBitmap.l[600]
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
MessageRequester("LOAD ERROR","File could not be opened")
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)
MessageRequester("LOAD ERROR","Not a valid gif file")
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
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
Else ;No local color table
If cl\bUseGlobalColMap=#False ;No global color table
CloseFile(file)
MessageRequester("LOAD ERROR","No 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)
MessageRequester("LOAD ERROR","LZW code size is not valid")
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)
MessageRequester("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)
MessageRequester("LOAD ERROR","Not a valid LZW code")
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)
FreeMemory(hDIB)
imageArray(0)=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)
globtranscolor=GlobalCols(transparent& $FF)
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)
Else ;No local color table
If cl\bUseGlobalColMap=#False ;No global color table
CloseFile(file)
MessageRequester("LOAD ERROR","No 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)
MessageRequester("LOAD ERROR","LZW code size is not valid")
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)
MessageRequester("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)
MessageRequester("LOAD ERROR","Not a valid LZW code")
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
If bImColTable ; if a local color table, then draw previous image in array, and then dray new hbitmap with transparency
DrawImage(imageArray(numberimages-1),0,0)
DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,loctranscolor)
Else
If tflag And disposalmethod <=1
DrawImage(imageArray(numberimages-1),0,0)
DrawTransparentImage(drawdc,hBitmap,im\imLeft,im\imTop,im\imWidth,im\imHeight,globtranscolor)
Else
DrawImage(imageArray(numberimages-1),0,0)
DrawImage(hBitmap,im\imLeft,im\imTop)
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())
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)
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
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(800)
;numberGIFs=LoadGIFframes(filename,myarray())
; UseGadgetList(WindowID(0))
; GifStaticControl(50,100,100,200,200,myarray.ANGIF())
; For a=1 To numberGIFs
; AddGadgetItem(0,a,"GIF Frame " + Str(a))
; CreateGadgetList(WindowID(a))
; ImageGadget(a*10,0,0,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