I found some old VB6 code that is a pure non-GDI+ GIF encoder. I have translated as much as i can, but i am stuck on some particular parts. Is there anyone who can try and clean up the VB code, which in turn when working will give the entire PB community the ability to naively save GIFs and even create animated GIFs.
I know the GIF decoding pretty well, and creating an animated GIF is just a matter of properly ENCODING each frame, and then whipping up a proper header for the frame which is cake.
My approach is to quantize the image, get the 8 bit pixel data, get the color table, and then send the pixel data to the translated VB encoder. What gets me, is how VB deals with arrays of bytes and using them as references in procedures as passed arguments. Well here is the code and thank you for anyone that can help.
Code: Select all
;- Variables needed for the GIF encoder
; GIF Encoder module
; http:www.syix.com/wpsjr1/index.html
; Based on code by: Christoph Hohmann (http:members.aol.com/rf21exe/gif.htm)
; Who based his code on code by: Michael A. Mayer
; Who apparently based his code on code by: Bob Montgomery circa 1988
;Dim file As cFile
; BitPacker
Global Dim Buffer.b(259)
;pos.l ; Position into buffer
;need.l
;bytesWritten.l
Global Dim bitmask.l(31)
Global Dim powers.l(31)
; GifCompressor
;nofdata.l ; Number of pixels in the data stream
;width.l ; Width of bitmap in pixels
;height.l ; Height of bitmap in pixels
;div8.l, div4.l, div2.l ; number of bitmap rows whose index is divisible by 8,4,2 If the row counting starts Withrow 0 = number of Bytes per Line As provided by the Windows GDI
;curordinal.l ; Ordinal number of next pixel to be encoded
;pixel.b ; Next pixel to be encoded
;dataDepth.l ; Length of the input data in bits. Possible values are 1..8. Still, each input item comes in a separate byte.
;nbits.l ; Current length of compression codes in bits (changes during encoding process)
;interlaced.l
Global Dim axon.i(4095)
Global Dim iNext.i(4095)
Global Dim pix.b(4096)
;cc .l ; "Clear code" which signals the clearing of the string table
;eoi.l ; "End-of-information code" which must be the last item of the code stream
;freecode.l ; Next code to be added to the string table
;widCount.l ; Makes division and multiplication to calculate padding unnecessary
;padding.l ; Cumulative padding (dword alignment)
; Property variables
;m_lLeft.l
;m_lTop.l
;m_lTransColor.l
;-NetMaestro's Procedures
Structure MyRGB
Red.b
Green.b
Blue.b
EndStructure
Structure _LTI_BITMAPINFO
bmiHeader.BITMAPINFOHEADER
bmiColors.RGBQUAD[1]
EndStructure
Structure _LTI_LONG
l.l
EndStructure
Procedure GrayscaleTable()
Global Dim GrayTable.RGBQUAD(256)
For i = 0 To 255
With GrayTable(i)
\rgbBlue = i
\rgbGreen = i
\rgbRed = i
\rgbReserved = 0
EndWith
Next
*palette = AllocateMemory(256*SizeOf(RGBQUAD))
CopyMemory(@GrayTable(),*palette, MemorySize(*palette))
Redim GrayTable(0)
ProcedureReturn *palette
EndProcedure
Procedure ColorTable()
*unpacked = AllocateMemory(824)
UnpackMemory(?ColorTable, *unpacked)
img0 = CatchImage(#PB_Any, *unpacked, 824)
FreeMemory(*unpacked)
DataSection
ColorTable:
Data.b $4A,$43,$38,$03,$00,$00,$4E,$C7,$B6,$7E,$B3,$A9,$D0,$20,$69,$14,$19,$88,$12,$CA
Data.b $08,$B0,$4A,$08,$25,$90,$0C,$30,$46,$02,$89,$81,$20,$70,$60,$10,$D8,$42,$AA,$91
Data.b $FF,$16,$02,$A9,$66,$80,$90,$84,$00,$68,$51,$20,$0A,$0C,$50,$52,$88,$02,$0A,$44
Data.b $81,$28,$A2,$40,$6D,$21,$86,$28,$10,$05,$14,$88,$02,$49,$64,$1B,$A2,$40,$02,$51
Data.b $20,$0A,$28,$D0,$76,$88,$20,$0A,$44,$81,$00,$48,$02,$49,$3A,$38,$10,$31,$14,$74
Data.b $28,$52,$24,$0C,$30,$40,$A2,$40,$14,$88,$A0,$A4,$10,$05,$14,$88,$02,$51,$44,$81
Data.b $DA,$42,$0C,$51,$20,$0A,$28,$10,$05,$92,$C8,$36,$44,$81,$05,$A2,$40,$14,$24,$81
Data.b $24,$10,$02,$49,$20,$09,$35,$3A,$14,$C8,$40,$B6,$01,$C3,$6D,$A0,$0E,$03,$20,$92
Data.b $30,$00,$14,$88,$02,$51,$44,$81,$92,$42,$0B,$51,$20,$0A,$28,$10,$05,$6A,$48,$32
Data.b $44,$81,$05,$A2,$40,$14,$24,$81,$24,$10,$0E,$49,$20,$09,$28,$10,$05,$DA,$20,$0B
Data.b $44,$81,$0C,$88,$02,$51,$88,$02,$49,$06,$05,$A2,$40,$14,$44,$81,$28,$10,$02,$51
Data.b $20,$0A,$A2,$40,$14,$88,$81,$28,$10,$05,$51,$20,$0A,$44,$40,$13,$68,$02,$28,$D0
Data.b $04,$9A,$20,$0A,$44,$81,$14,$88,$02,$51,$10,$05,$A2,$40,$68,$88,$82,$28,$0A,$D4
Data.b $16,$30,$88,$02,$51,$20,$05,$A2,$40,$14,$44,$81,$28,$10,$02,$51,$20,$0A,$9A,$40
Data.b $14,$88,$81,$26,$D0,$04,$51,$20,$0A,$34,$40,$14,$88,$02,$28,$10,$05,$A2,$20,$0A
Data.b $44,$81,$14,$88,$02,$51,$57,$0A,$A2,$40,$50,$52,$C0,$A0,$0A,$44,$81,$28,$88,$02
Data.b $51,$20,$05,$A2,$40,$14,$34,$81,$26,$10,$02,$4D,$A0,$09,$A2,$40,$14,$88,$81,$28
Data.b $10,$05,$51,$20,$0A,$44,$40,$14,$88,$02,$28,$10,$05,$A2,$20,$0A,$44,$81,$2C,$88
Data.b $02,$51,$24,$01,$83,$36,$10,$05,$A2,$40,$09,$44,$81,$28,$68,$02,$4D,$A0,$05,$A2
Data.b $40,$13,$44,$81,$28,$10,$02,$51,$20,$0A,$A2,$40,$14,$88,$81,$28,$10,$05,$51,$20
Data.b $0A,$44,$40,$14,$88,$02,$28,$10,$05,$A2,$20,$0A,$44,$81,$A8,$B4,$3C,$B4,$5A,$50
Data.b $04,$30,$80,$51,$00,$A2,$8E,$3E,$80,$22,$22,$80,$11,$C9,$A0,$08,$14,$81,$11,$28
Data.b $02,$45,$50,$04,$8A,$40,$08,$14,$81,$22,$28,$02,$45,$A0,$04,$8A,$40,$11,$14,$81
Data.b $22,$50,$02,$45,$A0,$08,$89,$40,$11,$28,$00,$40,$24,$32
ColorTableend:
EndDataSection
Global Dim ctable.RGBQUAD(256)
cc=0
StartDrawing(ImageOutput(img0))
For j=0 To 7
For i=0 To 31
Col = Point(i,j)
With ctable(cc)
\rgbBlue = Blue(Col)
\rgbGreen = Green(Col)
\rgbRed = Red(Col)
\rgbReserved = 0
EndWith
cc+1
Next
Next
StopDrawing()
FreeImage(img0)
*palette = AllocateMemory(256*SizeOf(RGBQUAD))
CopyMemory(@ctable(),*palette, MemorySize(*palette))
Redim ctable(0)
ProcedureReturn *palette
EndProcedure
Procedure Get32BitColors(pBitmap)
GetObject_(ImageID(pBitmap), SizeOf(BITMAP), @Bmp.BITMAP)
With BmiInfo.BITMAPINFOHEADER
\biSize = SizeOf(BITMAPINFOHEADER)
\biWidth = Bmp\bmWidth
\biHeight = -Bmp\bmHeight
\biPlanes = 1
\biBitCount = 32
\biCompression = #BI_RGB
EndWith
*pPixels = AllocateMemory(4*Bmp\bmWidth*Bmp\bmHeight)
hdc = GetWindowDC_(#Null)
iRes = GetDIBits_(hdc, ImageID(pBitmap), 0, Bmp\bmHeight , *pPixels, @BmiInfo, #DIB_RGB_COLORS)
ReleaseDC_(#Null, hdc)
ProcedureReturn *pPixels
EndProcedure
Procedure AdaptiveColorTable(pBitmap)
*pPixels = Get32BitColors(pBitmap)
Global Dim ColorBits.l(MemorySize(*pPixels)/4)
CopyMemory(*pPixels,ColorBits(),MemorySize(*pPixels))
FreeMemory(*pPixels)
SortArray(ColorBits(),#PB_Sort_Ascending)
Global Dim Apalette(256)
x = ArraySize(ColorBits())/256
cc=0
lastcolor = ColorBits(0)-1
For i = 0 To 255
If ColorBits(cc)<>lastcolor
Apalette(i) = ColorBits(cc)
lastcolor = ColorBits(cc)
cc+x
Else
While ColorBits(cc) = lastcolor And cc < ArraySize(ColorBits())
cc+1
Wend
x = (ArraySize(ColorBits())-cc)/(256-i)
cc+x-1
Apalette(i) = ColorBits(cc)
lastcolor = ColorBits(cc)
EndIf
Next
Redim ColorBits.l(0)
*palette = AllocateMemory(256*SizeOf(RGBQUAD))
CopyMemory(@Apalette(),*palette, MemorySize(*palette))
Redim Apalette(0)
ProcedureReturn *palette
EndProcedure
ProcedureDLL ImageTo8bit(hImageIn, Palette, free)
Select Palette
Case 0
*palette = GrayscaleTable()
Case 1
*palette = ColorTable()
Case 2
*palette = AdaptiveColorTable(hImageIn)
Default
*palette = ColorTable()
EndSelect
GetObject_(ImageID(hImageIn),SizeOf(BITMAP),Bmp.BITMAP)
w = Bmp\bmWidth
h = Bmp\bmHeight
d = Bmp\bmBitsPixel
hImageOut = CreateImage(#PB_Any,w,h,8)
hdc = StartDrawing(ImageOutput(hImageOut))
SetDIBColorTable_(hdc,0,256,*palette)
With bmi.BITMAPINFO
\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
\bmiHeader\biWidth = w
\bmiHeader\biHeight = -h
\bmiHeader\biPlanes = 1
\bmiHeader\biBitCount = d
\bmiHeader\biCompression = #BI_RGB
EndWith
GetDIBits_(hdc,ImageID(hImageIn),0,0, #Null, bmi.BITMAPINFO, #DIB_RGB_COLORS)
*bits = AllocateMemory(bmi\bmiHeader\biSizeImage)
GetDIBits_(hdc,ImageID(hImageIn),0,h, *bits, bmi.BITMAPINFO, #DIB_RGB_COLORS)
SetDIBits_(hdc,ImageID(hImageOut),0,h,*bits,bmi,#DIB_PAL_COLORS)
StopDrawing()
FreeMemory(*bits)
FreeMemory(*palette)
If free
FreeImage(hImageIn)
EndIf
ProcedureReturn hImageOut
EndProcedure
ProcedureDLL Save8bitImage(image, Filename$, Memory=0)
If Not IsImage(image) Or ImageDepth(image) <> 8
ProcedureReturn 0
EndIf
If GetObject_(ImageID(image), SizeOf(BITMAP), Bmp.BITMAP)
With BmiInfo.BITMAPINFOHEADER
\biSize = SizeOf(BITMAPINFOHEADER)
\biWidth = Bmp\bmWidth
\biHeight = Bmp\bmHeight
\biPlanes = 1
\biBitCount = 8
\biCompression = #BI_RGB
EndWith
Else
ProcedureReturn 0
EndIf
sz_colorbits = Bmp\bmWidthBytes*Bmp\bmHeight
*colortable = AllocateMemory(256*SizeOf(RGBQUAD))
hdc = StartDrawing(ImageOutput(image))
NumColors = GetDIBColorTable_(hdc, 0, 256, *colortable)
StopDrawing()
sz_image = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD) + sz_colorbits
*rawimage = AllocateMemory(sz_image)
*fileheader.BITMAPFILEHEADER = *rawimage
*header = *rawimage + SizeOf(BITMAPFILEHEADER)
With *fileheader
\bfType = PeekW(@"BM")
\bfSize = sz_image
\bfOffBits = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD)
EndWith
CopyMemory(BmiInfo, *header, SizeOf(BITMAPINFOHEADER))
CopyMemory(*colortable, *rawimage + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER), NumColors*SizeOf(RGBQUAD))
CopyMemory(Bmp\bmBits, *rawimage + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD), sz_colorbits)
FreeMemory(*colortable)
If Not Memory
file = CreateFile(#PB_Any, Filename$)
If file
WriteData(file,*rawimage,MemorySize(*rawimage))
CloseFile(file)
EndIf
FreeMemory(*rawimage)
ProcedureReturn 1
Else
ProcedureReturn *rawimage
EndIf
EndProcedure
;- Translated VB GIF encoder
Procedure Max( a.l, b.l)
If a > b
Max = a
ProcedureReturn Max
Else
Max = b
ProcedureReturn Max
EndIf
EndProcedure
; Binary search through 1 to 8
; Tests out faster than a jump table with select case
Procedure DivideCode3( code.l, need.l)
If need > 4
If need > 6 ; 7 - 8
If need = 7
DivideCode3 = code / 128
ProcedureReturn DivideCode3
Else ; 8
DivideCode3 = code / 256
ProcedureReturn DivideCode3
EndIf
Else ; 5 - 6
If need = 5
DivideCode3 = code / 32
ProcedureReturn DivideCode3
Else ; 6
DivideCode3 = code / 64
ProcedureReturn DivideCode3
EndIf
EndIf
Else ; 1 - 4
If need > 2 ; 3 - 4
ProcedureReturn DivideCode3
If need = 3
DivideCode3 = code / 8
ProcedureReturn DivideCode3
Else ; 4
DivideCode3 = code / 16
ProcedureReturn DivideCode3
EndIf
Else
If need = 2
DivideCode3 = code / 4
ProcedureReturn DivideCode3
Else ; 1
DivideCode3 = code / 2
ProcedureReturn DivideCode3
EndIf
EndIf
EndIf
EndProcedure
; BitPacker
; Obviously this function would be faster in a language with shifting operators
; VB.NET 05 has them, but it has GDI+ for GIF too
Macro AddCode(code.l, n.l, GIFFile)
;mask.l
;i.l
mask = bitmask(need)
While n >= need
buffer(pos) = buffer(pos) + ((code&mask) * powers(8 - need))
pos = pos + 1
buffer(pos) = 0
code = code \ powers(need)
code = DivideCode3(code, need) ; ~5% faster
n = n - need
need = 8
mask = 255
Wend
If n > 0
buffer(pos) = buffer(pos) + ((code & bitmask(n)) * powers(8 - need))
need = need - n
EndIf
If pos >= 255 ; pos pointing to buffer[255] or beyond
WriteByte(GIFFile, 255) ; write the "bytecount-byte"
WriteByte(GIFFile, 255) ; write buffer[0..254] to file
buffer(0) = buffer(255) ; rotate the following bytes,
buffer(1) = buffer(256) ; which may still contain data, to the
buffer(2) = buffer(257) ; beginning of buffer, and point
buffer(3) = buffer(258) ; (pos,need) to the position for new
pos = pos - 255 ; input (;need; can stay unchanged)
bytesWritten = bytesWritten + 256
EndIf
AddCode = pos
EndMacro
Macro Flush(GIFFile)
; Writes any data contained in ;Buffer; to the file as one data block of
; 1<=length<=255. Clears ;Buffer; and reinitializes for new data.
If need < 8
pos = pos + 1
buffer(pos) = 0
EndIf
If pos > 0
WriteByte(GIFFile,pos)
;WriteToFile Buffer, pos
bytesWritten = bytesWritten + pos + 1
EndIf
EndMacro
; GifCompressor
Procedure GetOffset(ordinal.l)
;Col.l
;Line.l
Col = ordinal % width
Line = ordinal \ width
If Line <= div8 ; If line is among the first div8 rows...
Line = Line * 8 ; ...it is dealt with during pass 1
ElseIf Line <= div4 ; If line is among the first div4 rows...
Line = (8 * (Line - div8)) - 4
ElseIf Line <= div2
Line = (4 * (Line - div4)) - 2
Else
Line = (2 * (Line - div2)) - 1
EndIf
GetOffset = Line * ((width + 3) & ~3) + Col
ProcedureReturn GetOffset
EndProcedure
Macro InitRoots()
;i.l
;rootCodes.l
rootCodes = powers(Max(2, dataDepth))
;Erase axon
For i = 0 To rootCodes - 1
pix(i) = i
Next i
EndMacro
Macro FlushStringTable()
Dim axon(0).i
EndMacro
Procedure FindPixelOutlet( headnode.l, pixel.b)
; Checks if the chain emanating from headnode;s axon contains a node
; for ;pixel;. Returns that node;s address (=code), Or 0 If there
; is no such node. (0 cannot be the root node 0, since root nodes
; occur in no chain).
outlet.l
outlet = axon(headnode)
While outlet
If pix(outlet) = pixel
FindPixelOutlet = outlet
ProcedureReturn FindPixelOutlet
Break
EndIf
outlet = iNext(outlet)
Wend
ProcedureReturn FindPixelOutlet
EndProcedure
Procedure Writer( Data())
; Writes the next code to the codestream and adds one entry to
; the Not stringtable. Does ;freecode;. Moves ;curordinal;
; forward and returns it pointing to the first pixel that hasn;t
; been encoded yet. Recognizes the end of the data stream.
;up.l
;down.l
up = pixel
curordinal = curordinal + 1
If curordinal = nofdata
AddCode(up, nbits)
;Exit Sub
EndIf
; Follow the string table and the data stream to the end of the
; longest string that has a code
widCount = widCount + 1
If widCount = width Then
padding = padding + (-width & 3)
widCount = 0
EndIf
If interlaced = False Then
pixel = Data(curordinal + padding)
Else
pixel = Data(GetOffset(curordinal))
EndIf
down = FindPixelOutlet(up, pixel)
While down <> 0
up = down
curordinal = curordinal + 1
If curordinal = nofdata ; End of data stream? Terminate
AddCode(up, nbits)
Break
EndIf
widCount = widCount + 1
If widCount = width ; Much faster than taking the mod each time
padding = padding + (-width & 3) ; Great bit hack :)
widCount = 0
EndIf
If interlaced = #False
pixel = Data(curordinal + padding)
Else
pixel = Data(GetOffset(curordinal))
EndIf
down = FindPixelOutlet(up, pixel)
Wend
; Submit up; which is the code of the longest string ...
AddCode(up, nbits)
; ... and extend the string by appending ;pixel;:
; Create a successor node for ;pixel; whose code is ;freecode;...
pix(freecode) = pixel
axon(freecode) = 0
iNext(freecode) = 0
; ...and link it to the end of the chain emanating from axon[up].
; Don ;t link it To the start instead: it would slow down performance.
down = axon(up)
If down = 0
axon(up) = freecode
Else
While iNext(down)
down = iNext(down)
Wend
iNext(down) = freecode
EndIf
EndProcedure
Procedure WriteDataBlocks(GIFFile, pixelData(), nof.l, wi.l, dd.l, il )
nofdata = nof ; number of pixels in data stream
width = wi ; bitmap width and height in pixels
height = nofdata \ width
interlaced = il
div8 = (height \ 8) - 1 ; needed to support interlacing
div4 = (height \ 4) - 1
div2 = (height \ 2) - 1
pixel = pixelData(0)
dataDepth = dd ; number of bits per data item (=pixel)
nbits = Max(3, dd + 1) ; initial size of compression codes
cc = powers(nbits - 1)
eoi = cc + 1 ; ;end-of-information;-code
freecode = cc + 2 ; code of the next entry to be added to the stringtable
InitRoots ; initialize the string table;s root nodes
; Write what the GIF specification calls the "code size".
; Confusingly, this is the number of bits required
; to represent the pixel values. Allowed are 2,3,4,5,6,7,8.
WriteByte(GIFFile,Max(dataDepth, 2))
AddCode(cc, nbits)
While curordinal <> nofdata
Writer(pixelData) ; generates the next code, and updates ;curordinal;
; if the latest code added to the stringtable exceeds ;nbits; bits:
If freecode = powers(nbits)
nbits = nbits + 1 ; increase size of compression codes by 1 bit
EndIf
freecode = freecode + 1
If freecode = $FFF
FlushStringTable() ; avoid stringtable overflow
AddCode(cc, nbits) ; tell the decoding software to flush its stringtable
nbits = Max(3, 1 + dataDepth)
freecode = cc + 2
EndIf
Wend
If curordinal = nofdata ; Now zero based
AddCode(eoi, nbits) ; Submit ;eoi; as the last item of the code stream
Flush() ; Write remaining codes including this ;eoi; to the binary file
WriteByte(GIFFile,0) ; Write an empty data block to signal the end of "raster data" section in the file
WriteDataBlocks = bytesWritten + 2
EndIf
EndProcedure
Procedure Initialize()
i .l
Value.l
; Reset some variables
pos = 0
curordinal = 0
bytesWritten = 0
widCount = 0
padding = 0
need = 8
; Clear some arrays
Erase Buffer
;FlushStringTable
;Erase iNext
;Erase pix
Value = 1
; Store some values for masking and shifting
For i = 0 To 29
powers(i) = Value
bitmask(i) = Value - 1
Value = Value * 2
Next i
bitmask(30) = $7FFFFFFF
bitmask(31) = $FFFFFFFF
powers(30) = $40000000
powers(31) = $80000000
;Set file = New cFile
EndProcedure
Procedure WriteToGif( filename.s, interlaced, bmi.BITMAPINFO256, array pixels())
; i.l
; clrUsed.l
; dataDepth.l
; ImageSize.l
; fileSize .l
; width.l
; height.l
;
; Initialize.l
; Overwrites file, you are responsible for user prompting, if desired
GIFFile=CreateFile(#PB_Any,filename)
If file.OpenFile(filename, GENERIC_WRITE, 0, CREATE_ALWAYS, FILE_FLAG_SEQUENTIAL_SCAN) Then
width = bmi.bmiHeader.biWidth
height = Abs(bmi.bmiHeader.biHeight)
ImageSize = width * height
file.WriteToFile StrConv("GIF89a", vbFromUnicode), 6 ; GIF signature
; Screen Descriptor
file.WriteIntegerToFile width ; Screen Width/Height
file.WriteIntegerToFile height
; Is a power of two between 2 and 256
clrUsed = bmi.bmiHeader.biClrUsed
; Compute its exponent ;dataDepth;
For i = 1 To clrUsed - 1 Step 0 ; Didn;t know you could Do that, did ya? :p
i = i * 2
dataDepth = dataDepth + 1
Next i
; Write datadepth-1 to the three least significant bits of byte 5
; of the Screen Descriptor
;&HF0 = Global Color Table 1 | Color Resolution 111 (Colors in original image)
; Sort Flag 0 (colors are not sorted) | Global Color Table Size (dataDepth - 1)
file.WriteByteToFile ((dataDepth - 1) & 7) |$F0
; Background color = colortable index 0
; Byte 7 must be 0x00
file.WriteIntegerToFile 0
; Global Color Table
; Gif color table is RGBTriple
For i = 0 To clrUsed - 1
file.WriteByteToFile bmi.bmiColors(i).rgbRed
file.WriteByteToFile bmi.bmiColors(i).rgbGreen
file.WriteByteToFile bmi.bmiColors(i).rgbBlue
Next
; Image Descriptor
file.WriteByteToFile $2C ; Image separator character = ;,;
file.WriteIntegerToFile 0 ; Image Left
file.WriteIntegerToFile 0 ; Image Top
file.WriteIntegerToFile width ; Image Width
file.WriteIntegerToFile height ; Image Height
; Byte 10 contains the interlaced flag and information on the local color table.
; There is no local color table if it;s most significant bit is reset.
If interlaced Then
file.WriteByteToFile ((dataDepth - 1) & 7) |$40
Else
file.WriteByteToFile (dataDepth - 1) & 7
EndIf
fileSize = 6 + 7 + 3 * clrUsed + 10 ; Calculate the Color Table Size
fileSize = fileSize + WriteDataBlocks(pixels, ImageSize, width, dataDepth, interlaced)
file.WriteByteToFile $3B ; GIF terminator, tells the decoder software to return
file.SetFileEnd
WriteToGif = fileSize + 1
file.CloseFile
EndIf
EndProcedure
;- My procedure to quantize the image and get the pixel data
Procedure SaveGIF(PBImage,filename.s)
If ImageDepth(PBImage)<8
ProcedureReturn 0
ElseIf ImageDepth(PBImage)=8
new8bimage=PBImage
Else
new8bimage=ImageTo8bit(PBImage,2,0)
EndIf
If Not IsImage(new8bimage) Or ImageDepth(new8bimage) <> 8
ProcedureReturn 0
EndIf
If GetObject_(ImageID(new8bimage), SizeOf(BITMAP), Bmp.BITMAP)
With BmiInfo.BITMAPINFOHEADER
\biSize = SizeOf(BITMAPINFOHEADER)
\biWidth = Bmp\bmWidth
\biHeight = -Bmp\bmHeight ;bitmap is TOP down
\biPlanes = 1
\biBitCount = 8
\biCompression = #BI_RGB
EndWith
Else
ProcedureReturn 0
EndIf
width = Bmp\bmWidth
height = Bmp\bmHeight
bitcount = Bmp\bmBitsPixel
pitch=(((width*bitcount)+31)/32)*4
sz_colorbits = Bmp\bmWidthBytes*Bmp\bmHeight
*bitmapdata=AllocateMemory(sz_colorbits)
*colortable = AllocateMemory(256*SizeOf(RGBQUAD))
hdc = StartDrawing(ImageOutput(new8bimage))
NumColors = GetDIBColorTable_(hdc, 0, 256, *colortable) ;get the color table
StopDrawing()
Dim CT1024.RGBQUAD(NumColors-1)
CopyMemory(*colortable,@CT1024(),NumColors*SizeOf(RGBQUAD)) ;copy our BGRI palette to a RGBQUAD array
CopyMemory(Bmp\bmBits, *bitmapdata, sz_colorbits) ;output all out pixel data
FreeMemory(*colortable)
Dim CT768.MyRGB(NumColors-1)
For a =0 To NumColors-1 ; Here we take the BGRI and switch it to a RGB VGA palette by bitshitfing >>2
CT768(a)\Red=CT1024(a)\rgbRed
CT768(a)\Green=CT1024(a)\rgbGreen
CT768(a)\Blue=CT1024(a)\rgbBlue
Next
;- Encode the GIF here *** once the VB encoder is correct
EndProcedure
