The following code is for public domain.
'Credits: The original code was written in VB by Arkadiy Olovyannikov
' It was revised by Joyprakash Saikia
' Wolfgang Goetz added code for transparent GIFs
'Translated to PowerBasic by Peter Redei
'---------------------------------------------------------------------
'BMP2GIF.BAS
'---------------------------------------------------------------------------------------
%LR_LOADFROMSTRING = -1
$GIF89a = "GIF89a"
$GIF87a = "GIF87a"
%GifTerminator = &H3B
%CtrlIntro = &H21
%CtrlLabel = &HF9
%ImageSeparator = &H2C
%CodeSize = 9
%CHAR_BIT = 8
%CodeSize = 9
%ClearCode = 256
%FirstCode = 258
%LastCode = 511
%MAX_CODE = %LastCode - %FirstCode
%EndCode = 257
GLOBAL data_buffer() AS BYTE
GLOBAL bit_position AS INTEGER
GLOBAL aPower2() AS LONG
GLOBAL colTable1() AS LONG
GLOBAL code_count AS LONG
GLOBAL colTable2() AS STRINGTYPE BITMAPINFO256
bmiHeader AS BITMAPINFOHEADER
bmiColors(0 TO 255) AS RGBQUAD
END TYPE
TYPE GifScreenDescriptor
logical_screen_width AS INTEGER
logical_screen_height AS INTEGER
Flags AS BYTE
background_color_index AS BYTE
pixel_aspect_ratio AS BYTE
END TYPETYPE GifImageDescriptor
gLeft AS INTEGER
Top AS INTEGER
gWidth AS INTEGER
Height AS INTEGER
Format AS BYTE 'ImageFormat
END TYPETYPE CONTROLBLOCK
Blocksize AS BYTE
Flags AS BYTE
Delay AS INTEGER
TransParent_Color AS BYTE
Terminator AS BYTE
END TYPE
GLOBAL hGDI32Lib AS LONG 'handle for the library
DECLARE FUNCTION FAL_CreateDIBSection256(BYVAL hDc AS LONG, pBitmapInfo AS BITMAPINFO256, BYVAL un AS LONG, lplpVoid AS LONG, BYVAL hndl AS LONG, BYVAL dw AS LONG) AS LONG
DECLARE FUNCTION FAL_GetDIBits256(BYVAL hdc AS LONG, BYVAL hBitmap AS LONG, BYVAL nStartScan AS LONG, BYVAL nNumScans AS LONG, lpBits AS BYTE, lpBI AS BITMAPINFO256, BYVAL wUsage AS LONG) AS LONG
SUB LoadGDI32Lib()
'this must be called in order to load the remail functions
IF hGDI32Lib = 0 THEN
hGDI32Lib = LoadLibrary("gdi32.dll")
END IF
END SUBSUB UnloadGDI32Lib()
'this must be called after an RemailLib call prior the application terminates!
IF hGDI32Lib <> 0 THEN
FreeLibrary hGDI32Lib
hGDI32Lib = 0
END IF
END SUBFUNCTION GetDIBits256(BYVAL hDc AS LONG, BYVAL hBitmap AS LONG, BYVAL nStartScan AS LONG, BYVAL nNumScans AS LONG, lpBits AS BYTE, lpBI AS BITMAPINFO256, BYVAL wUsage AS LONG) AS LONG
LOCAL procAddr AS DWORD
LOCAL hRes AS LONG
IF hGDI32Lib = 0 THEN
FUNCTION = 0
ELSE
procAddr = GetProcAddress(hGDI32Lib, "GetDIBits")
CALL DWORD procAddr USING FAL_GetDIBits256(hDc, hBitmap, nStartScan, nNumScans, lpBits, lpBI, wUsage) TO hRes
FUNCTION = hRes
END IF
END FUNCTIONFUNCTION CreateDIBSection256(BYVAL hDc AS LONG, pBitmapInfo AS BITMAPINFO256, BYVAL un AS LONG, lplpVoid AS LONG, BYVAL hndl AS LONG, BYVAL dw AS LONG) AS LONG
LOCAL procAddr AS DWORD
LOCAL hRes AS LONG
IF hGDI32Lib = 0 THEN
FUNCTION = 0
ELSE
procAddr = GetProcAddress(hGDI32Lib, "CreateDIBSection")
CALL DWORD procAddr USING FAL_CreateDIBSection256(hDc, pBitmapInfo, un, lplpVoid, hndl, dw) TO hRes
FUNCTION = hRes
END IF
END FUNCTIONFUNCTION Power2(BYVAL i AS INTEGER) AS LONGIF aPower2(0) = 0 THEN
aPower2(0) = &H1&
aPower2(1) = &H2&
aPower2(2) = &H4&
aPower2(3) = &H8&
aPower2(4) = &H10&
aPower2(5) = &H20&
aPower2(6) = &H40&
aPower2(7) = &H80&
aPower2(8) = &H100&
aPower2(9) = &H200&
aPower2(10) = &H400&
aPower2(11) = &H800&
aPower2(12) = &H1000&
aPower2(13) = &H2000&
aPower2(14) = &H4000&
aPower2(15) = &H8000&
aPower2(16) = &H10000
aPower2(17) = &H20000
aPower2(18) = &H40000
aPower2(19) = &H80000
aPower2(20) = &H100000
aPower2(21) = &H200000
aPower2(22) = &H400000
aPower2(23) = &H800000
aPower2(24) = &H1000000
aPower2(25) = &H2000000
aPower2(26) = &H4000000
aPower2(27) = &H8000000
aPower2(28) = &H10000000
aPower2(29) = &H20000000
aPower2(30) = &H40000000
aPower2(31) = &H80000000
END IF
Power2 = aPower2(i)
END FUNCTION
FUNCTION CreateDib256(BYVAL hDc AS LONG, bi AS BITMAPINFO256, picWidth AS LONG, picHeight AS LONG) AS LONG' Purpose :creates a DIB that applications can write to directly.
' Here it is restricted to 256 color
' The function gives you a pointer to the location of the bitmap bit
' values.
LOCAL lScanSize AS LONG
LOCAL colPal AS LONG
LOCAL colPal1 AS LONG
LOCAL colPal2 AS LONG
LOCAL lptr AS LONG, lIndex AS LONG
LOCAL rgbRed AS LONG, rgbGreen AS LONG, rgbBlue AS LONGbi.bmiHeader.biSize = SIZEOF(bi.bmiHeader)
bi.bmiHeader.biWidth = picWidth
bi.bmiHeader.biHeight = picHeight
bi.bmiHeader.biPlanes = 1
bi.bmiHeader.biBitCount = 8
bi.bmiHeader.biCompression = %BI_RGB
lScanSize = (picWidth + picWidth MOD 4)
bi.bmiHeader.biSizeImage = lScanSize * picHeight' Halftone 256 colour palette
FOR colPal = 0 TO &H100 STEP &H40
IF colPal = &H100 THEN
rgbBlue = colPal - 1
ELSE
rgbBlue = colPal
END IF
FOR colPal1 = 0 TO &H100 STEP &H40
IF colPal1 = &H100 THEN
rgbGreen = colPal1 - 1
ELSE
rgbGreen = colPal1
END IF
FOR colPal2 = 0 TO &H100 STEP &H40
IF colPal2 = &H100 THEN
rgbRed = colPal2 - 1
ELSE
rgbRed = colPal2
END IFbi.bmiColors(lIndex).rgbRed = rgbRed
bi.bmiColors(lIndex).rgbGreen = rgbGreen
bi.bmiColors(lIndex).rgbBlue = rgbBlueINCR lIndex
NEXT
NEXT
NEXT
FUNCTION = CreateDIBSection256(hDc, bi, %DIB_RGB_COLORS, lptr, 0, 0)
END FUNCTIONSUB OutputBits(fn AS LONG, Value AS INTEGER, count AS INTEGER)
' Purpose : Put the Output Bit after Compression to DATABUFFERLOCAL i AS LONG
LOCAL iBit AS LONG
DO WHILE i < count
IF bit_position = %CHAR_BIT THEN
IF data_buffer(0) = 255 THEN
PUT #fn, , data_buffer()
data_buffer(0) = 1
ELSE
data_buffer(0) = data_buffer(0) + 1
END IF
data_buffer(data_buffer(0)) = 0
bit_position = 0
END IF
iBit = SGN(Power2(i) AND Value)
IF iBit > 0 THEN
data_buffer(data_buffer(0)) = Power2(bit_position) OR data_buffer(data_buffer(0))
END IF
INCR i : INCR bit_position
LOOP
END SUBSUB ClearTable()
REDIM colTable1(0)
REDIM colTable2(0)
END SUBSUB Reinitialize(v AS LONG)
ClearTable
CALL OutputBits(v, %ClearCode, %CodeSize)
END SUBSUB OutputCode(v AS LONG, code AS LONG)
' Purpose : To Create Output for Clear Code beyond 256INCR code_count
IF code_count > %LastCode THEN
code_count = %FirstCode
CALL OutputBits(v, %ClearCode, %CodeSize)
ClearTable 'Erase and recreate the Color Table
END IF
CALL OutputBits(v, BYCOPY code, %CodeSize)
END SUBFUNCTION MyFormat(BYVAL s AS STRING) AS STRING
MyFormat = RIGHT$("00" & s, 3)
END FUNCTIONFUNCTION IsInTable(sText AS STRING) AS LONG
LOCAL i AS LONG
FOR i = 1 TO UBOUND(colTable2)
IF colTable2(i) = sText THEN FUNCTION = i:EXIT FOR
NEXT
END FUNCTIONFUNCTION SaveGIF(sBMPFile AS ASCIIZ, sGIFFile AS ASCIIZ, _
hDc AS LONG, UseTrans AS LONG, _
BYVAL TransColor AS LONG) AS LONGLOCAL hBmp AS LONG
LOCAL hPalette AS LONG
LOCAL bm AS BITMAP
LOCAL picWidth AS LONG
LOCAL picHeight AS LONG
LOCAL buf() AS BYTE
LOCAL hDCScn AS LONG
LOCAL hDC256 AS LONG
LOCAL OldObj AS LONG
LOCAL hMemDC AS LONG
LOCAL hDib256 AS LONG
LOCAL bi AS BITMAPINFO256
LOCAL OldObj256 AS LONG
LOCAL i AS INTEGER
LOCAL bFound AS LONG
LOCAL clr AS LONG
LOCAL TransIndex AS BYTE
LOCAL scr AS GifScreenDescriptor
LOCAL im AS GifImageDescriptor
LOCAL v AS LONG
LOCAL cb AS CONTROLBLOCK
LOCAL gifData AS BYTE
LOCAL sPrefix AS STRING
LOCAL intCode AS INTEGER
LOCAL j AS LONG
LOCAL sByte AS STRING
LOCAL x AS LONG
LOCAL nCount AS LONG
LOCAL sTmp AS STRING
LOCAL sByt AS BYTEREDIM aPower2(31)
code_count = 0hBmp = LoadImage(0&, sBMPFile, %IMAGE_BITMAP, 0, 0, %LR_LOADFROMFILE)
GetObject hBmp, SIZEOF(bm), bm
picWidth = bm.bmWidth
picHeight = bm.bmHeight
REDIM buf(CLNG(((picWidth + 3) \ 4) * 4), picHeight) AS BYTE
'Prepare DC for paintings
hDCScn = CreateDC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
hDC256 = CreateCompatibleDC(hDCScn)
IF hDc = 0 THEN
hMemDC = CreateCompatibleDC(hDCScn)
OldObj = SelectObject(hMemDC, hBmp)
ELSE
hMemDC = hDc
END IF
DeleteDC hDCScn'Since GIF works only with 256 colors, reduce color depth to 256
'This sample use simpliest HalfTone palette to reduce color depthIF bm.bmBitsPixel <> 8 THEN hDib256 = CreateDib256(hDC256, bi, picWidth, picHeight) 'Create DC with 256
IF hDib256 <> 0 THEN
OldObj256 = SelectObject(hDC256, hDib256)
CALL BitBlt(hDC256, 0, 0, picWidth, picHeight, hMemDC, 0, 0, &HCC0020)
FOR i = 0 TO picHeight - 1
CALL GetDIBits256(hDC256, hDib256, i, 1, buf(0, picHeight - i), bi, 0)
NEXT
ELSE
'Put the Header of the File
bi.bmiHeader.biSize = SIZEOF(bi.bmiHeader)
bi.bmiHeader.biWidth = picWidth
bi.bmiHeader.biHeight = picHeight
bi.bmiHeader.biPlanes = 1
bi.bmiHeader.biBitCount = 8
bi.bmiHeader.biCompression = %BI_RGB
FOR i = 0 TO picHeight - 1
CALL GetDIBits256(hMemDC, hBmp, i, 1, buf(0, picHeight - i), bi, 0)
NEXT
END IF'Fill gif file info
REDIM gifPalette(0 TO 255) AS RGBTRIPLE
FOR i = 0 TO 255 'RGB Patterns
gifPalette(i).rgbtBlue = bi.bmiColors(i).rgbBlue
gifPalette(i).rgbtGreen = bi.bmiColors(i).rgbGreen
gifPalette(i).rgbtRed = bi.bmiColors(i).rgbRed
IF NOT bFound THEN
clr = RGB(gifPalette(i).rgbtRed, gifPalette(i).rgbtGreen, gifPalette(i).rgbtBlue)
IF clr = TransColor THEN
TransIndex = i: bFound = %True
END IF
END IF
NEXTscr.background_color_index = 0
scr.Flags = &HF7 '256-color gif with global color map
scr.pixel_aspect_ratio = 0im.Format = &H7 'GlobalNonInterlaced
im.Height = picHeight
im.gWidth = picWidth' If the output File Exists simply overwrite
IF DIR$(sGIFFile) > "" THEN KILL sGIFFilev = FREEFILE
OPEN sGIFFile FOR BINARY AS #v
'Write GIF header and header info
IF ISTRUE(UseTrans) THEN
sTmp = $GIF89a
PUT #v, , sTmp
ELSE
sTmp = $GIF87a
PUT #v, , sTmp
END IF
PUT #v, , scr
PUT #v, , gifPalette()IF ISTRUE(UseTrans) THEN
sByt = CBYT(%CtrlIntro)
PUT #v, , sByt
sByt = CBYT(%CtrlLabel)
PUT #v, , sBytcb.Blocksize = 4 'Always 4
cb.Flags = 9 'Packed = 00001001 (If Bit 0 = 1: Use Transparency)
cb.Delay = 0
cb.TransParent_Color = TransIndex
cb.Terminator = 0 'Always 0
PUT #v, , cb
END IF
sByt = CBYT(%ImageSeparator)
PUT #v, , sByt
PUT #v, , im
gifData = %CodeSize - 1
PUT #v, , gifData
data_buffer(0) = 0
bit_position = %CHAR_BIT
'Process pixels data using LZW/GIF compression
FOR i = 1 TO picHeight
Reinitialize v
sPrefix = ""
intCode = buf(0, i)
ON ERROR RESUME NEXT
FOR j = 1 TO picWidth - 1
sTmp = FORMAT$(buf(j, i))
sByte = MyFormat(sTmp)
sPrefix = sPrefix & sByte
x = IsInTable(sPrefix)
IF x > 0 THEN
intCode = colTable1(x)
ELSE
nCount = UBOUND(colTable1)
IF nCount = %MAX_CODE THEN Reinitialize v
REDIM PRESERVE colTable1(UBOUND(colTable1) + 1)
REDIM PRESERVE colTable2(UBOUND(colTable2) + 1)
colTable1(UBOUND(colTable1)) = nCount + %FirstCode
colTable2(UBOUND(colTable2)) = sPrefix
OutputBits v, intCode, %CodeSize
sPrefix = sByte
intCode = buf(j, i)
END IF
NEXT
OutputBits v, intCode, %CodeSize
NEXTOutputCode v, %EndCode
FOR i = 0 TO data_buffer(0)
PUT #v, , data_buffer(i)
NEXT
gifData = 0
PUT #v, , gifData
sByt = CBYT(%GifTerminator)
PUT #v, , sByt
CLOSE #v
ERASE buf
IF hDc = 0 THEN
SelectObject hMemDC, OldObj
DeleteDC hMemDC
END IF
SelectObject hDC256, OldObj256
DeleteObject hDib256
DeleteDC hDC256
FUNCTION = %TrueEND FUNCTION
'---------------------------------------------------------------------
'sample application using PBForms
'BMPtoGIF.bas
#PBFORMS Created
'--------------------------------------------------------------------------------
' The first line in this file is a PBForms metastatement.
' It should ALWAYS be the first line of the file. Other
' PBForms metastatements are placed at the beginning and
' ending of blocks of code that should be edited using
' PBForms only. Do not edit or delete these
' metastatements or PBForms will not be able to reread
' the file correctly. See the PBForms documentation for
' more information.
' Beginning blocks begin like this: #PBForms Begin ...
' Ending blocks begin like this: #PBForms End ...
' Other PBForms metastatements such as:
' #PBForms Declarations
' are used to tell PBForms where to insert additional
' code. Feel free to make changes anywhere else in the file.
'--------------------------------------------------------------------------------#COMPILE EXE
#DIM ALL'--------------------------------------------------------------------------------
' ** Includes **
'--------------------------------------------------------------------------------
#PBFORMS Begin Includes
#IF NOT %DEF(%WINAPI)
#INCLUDE "WIN32API.INC"
#ENDIF
#PBFORMS End Includes
'--------------------------------------------------------------------------------
#INCLUDE "win32api.inc"
#INCLUDE "COMDLG32.INC"
#INCLUDE "bmp2gif.bas"
'--------------------------------------------------------------------------------
' ** Constants **
'--------------------------------------------------------------------------------
#PBFORMS Begin Constants
%IDD_DIALOG1 = 101
%IDC_LABEL1 = 1001
%IDC_LABEL2 = 1002
%IDC_TEXTBOX1 = 1003
%IDC_TEXTBOX2 = 1004
%IDC_BUTTON1 = 1005
%IDC_BUTTON2 = 1006
#PBFORMS End Constants
'--------------------------------------------------------------------------------'--------------------------------------------------------------------------------
' ** Declarations **
'--------------------------------------------------------------------------------
DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
#PBFORMS Declarations
'--------------------------------------------------------------------------------'--------------------------------------------------------------------------------
FUNCTION PBMAIN()
ShowDIALOG1 %HWND_DESKTOP
END FUNCTION'--------------------------------------------------------------------------------'--------------------------------------------------------------------------------
' ** CallBacks **
'--------------------------------------------------------------------------------
CALLBACK FUNCTION ShowDIALOG1Proc()
LOCAL bmpFile AS STRING
LOCAL gifFile AS STRING
ON ERROR GOTO ErrSub
SELECT CASE CBMSG
CASE %WM_INITDIALOG
REDIM data_buffer(255)
LoadGDI32Lib
CASE %WM_DESTROY
UnloadGDI32Lib
CASE %WM_COMMAND
SELECT CASE CBCTL
CASE %IDC_LABEL1
CASE %IDC_LABEL2
CASE %IDC_TEXTBOX1
CASE %IDC_TEXTBOX2
CASE %IDC_BUTTON1
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
IF OpenFileDialog(CBHNDL, _
"Select the BMP file to convert", _
bmpFile, _
"C:\", _
"BMP files|*.bmp", _
"*.bmp", _
%OFN_EXPLORER OR %OFN_NODEREFERENCELINKS) THENREPLACE CHR$(0) WITH CHR$(13) IN bmpFile
IF bmpFile > "" THEN
CONTROL SET TEXT CBHNDL, %IDC_TEXTBOX1, bmpFile
gifFile = bmpFile
MID$(gifFile, LEN(gifFile) - 2, 3) = "gif"
CONTROL SET TEXT CBHNDL, %IDC_TEXTBOX2, gifFile
END IF
END IF
END IF
CASE %IDC_BUTTON2
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET TEXT CBHNDL, %IDC_TEXTBOX1 TO bmpFile
CONTROL GET TEXT CBHNDL, %IDC_TEXTBOX2 TO gifFile
IF bmpFile > "" AND gifFile > "" THEN
IF DIR$(bmpFile) > "" THEN
IF ISTRUE SaveGIF(BYCOPY bmpFile,BYCOPY gifFile, 0, 0, 0) THEN
MSGBOX "Done"
ELSE
MSGBOX "Error"
END IF
END IF
END IF
END IFEND SELECT
END SELECT
xErrSub:
EXIT FUNCTION
ErrSub:
RESUME xErrSub
END FUNCTION'--------------------------------------------------------------------------------'--------------------------------------------------------------------------------
' ** Dialogs **
'--------------------------------------------------------------------------------
FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
LOCAL lRslt AS LONG
#PBFORMS Begin Dialog %IDD_DIALOG1->->
LOCAL hDlg AS DWORD
DIALOG NEW hParent, "BMP to GIF", 69, 76, 310, 63, %WS_POPUP OR %WS_BORDER _
OR %WS_DLGFRAME OR %WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_CLIPSIBLINGS _
OR %WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_WINDOWEDGE OR %WS_EX_CONTROLPARENT OR %WS_EX_LEFT _
OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "BMP file", 5, 5, 50, 10
CONTROL ADD LABEL, hDlg, %IDC_LABEL2, "GIF file to create", 5, 25, 55, 10
CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX1, "", 60, 5, 190, 13
CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX2, "", 60, 20, 190, 13
CONTROL ADD BUTTON, hDlg, %IDC_BUTTON1, "Browse", 255, 5, 50, 15
CONTROL ADD BUTTON, hDlg, %IDC_BUTTON2, "Create GIF", 5, 40, 80, 15#PBFORMS End DialogDIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRsltFUNCTION = lRslt
END FUNCTION