کد:
%MAXWRITE = 4096 '4 Kbyte
TYPE BITMAPINFOQ 'Modified version of BITMAPINFO
bmiHeader AS BITMAPINFOHEADER
bmiColors AS STRING*(256*4) '256 * SIZEOF(RGBQUAD)
END TYPE
FUNCTION ShiftLeft (BYVAL iVar AS LONG, BYVAL iCount AS LONG) AS LONG
LOCAL iRes AS LONG
iRes = iVar
SHIFT LEFT iRes, iCount
FUNCTION = iRes
END FUNCTION
FUNCTION ShiftRight (BYVAL iVar AS LONG, BYVAL iCount AS LONG) AS LONG
LOCAL iRes AS LONG
iRes = iVar
SHIFT RIGHT iRes, iCount
FUNCTION = iRes
END FUNCTION
' ----------------------------------------------------------------
'FUNCTION CreateBitmapInfoStruct (BYVAL hBmp AS DWORD,_
' bmiHeader AS BITMAPINFOHEADER) AS LONG
' This function initialises the members of a BITMAPINFOHEADER structure
' for an uncompressed bitmap. Returns %TRUE for success, else %FALSE.
'
FUNCTION CreateBitmapInfoStruct (BYVAL hBmp AS DWORD,_
bmiHeader AS BITMAPINFOHEADER) AS LONG
LOCAL bmp AS BITMAP,_
cClrBits AS WORD
FUNCTION = %FALSE
'Retrieve the bitmap's color format, width, and height
'-----------------------------------------------------
IF 0 = GetObject(hBmp, SIZEOF(bmp), bmp) THEN EXIT FUNCTION
'Convert the color format to a count of bits
'-------------------------------------------
SELECT CASE AS LONG (bmp.bmPlanes * bmp.bmBitsPixel)
CASE 1 :cClrBits = 1
CASE <= 4 :cClrBits = 4
CASE <= 8 :cClrBits = 8
CASE <= 16 :cClrBits = 16
CASE <= 24 :cClrBits = 24
CASE ELSE :cClrBits = 32
END SELECT
'Initialize the fields in the BITMAPINFO structure
'-------------------------------------------------
bmiHeader.biSize = SIZEOF(BITMAPINFOHEADER)
bmiHeader.biWidth = bmp.bmWidth
bmiHeader.biHeight = bmp.bmHeight
bmiHeader.biPlanes = bmp.bmPlanes
bmiHeader.biBitCount = bmp.bmBitsPixel
IF cClrBits < 24 THEN bmiHeader.biClrUsed = ShiftLeft(1, cClrBits)
'Since bitmap is uncompressed, set the BI_RGB flag
'-------------------------------------------------
bmiHeader.biCompression = %BI_RGB
'Compute the number of bytes in the array of color indices *.
'---------------------------------------------------------
bmiHeader.biSizeImage = _
((bmiHeader.biWidth*cClrBits + 31) AND NOT(31)) / 8 _
* bmiHeader.biHeight
'Set biClrImportant to 0, indicating that all of the
'device colors are important.
'------------------------------
bmiHeader.biClrImportant = 0
FUNCTION = %TRUE
END FUNCTION
'NOTE: * For Windows NT, the width must be DWORD aligned unless the bitmap
' is RLE compressed. This example shows this. For Windows 95/98/Me,
' the width must be WORD aligned unless the bitmap is RLE compressed.
'
' --------------------------------------------------------------
'FUNCTION CreateBMPFile (sFile AS STRING, hBmp AS DWORD, hDC AS DWORD) AS LONG
'
' Saves a bitmap to a file. Returns %TRUE for success, else %FALSE.
'
FUNCTION CreateBMPFile (sFile AS STRING, hBmp AS DWORD, hDC AS DWORD) AS LONG
LOCAL iRet AS LONG,_
dwTmp AS LONG,_
hf AS DWORD,_ 'file handle
pbi AS BITMAPINFOQ,_
hdr AS BITMAPFILEHEADER,_ 'bitmap file-header
pbih AS BITMAPINFOHEADER,_ 'bitmap info-header
lpBits AS STRING,_ 'memory buffer
dwTotal AS DWORD,_ 'total count of bytes
cb AS DWORD,_ 'incremental count of bytes
hp AS BYTE PTR 'byte pointer
iRet = %FALSE
FUNCTION = iRet
'Create BITMAPINFO structure
'---------------------------
IF ISFALSE CreateBitmapInfoStruct (hBmp, pbi.bmiHeader) THEN EXIT FUNCTION
'Initialize BITMAPINFOHEADER fields
'----------------------------------
pbih = pbi.bmiHeader
'Get bits array and color table (RGBQUAD array)
'----------------------------------------------
lpBits = SPACE$(pbih.biSizeImage) 'Buffer for bitmap bits
IF 0 = GetDIBits (hDC, hBMP, 0, pbih.biHeight, BYVAL STRPTR(lpBits),_
BYVAL VARPTR(pbi), %DIB_RGB_COLORS) THEN EXIT FUNCTION
'Initialize fields of BITMAPFILEHEADER
'-------------------------------------
hdr.bfType = &H4D42 '"BM",ie. &H42 = "B" &H4D = "M"
hdr.bfOffBits = SIZEOF(hdr) + pbih.biSize _ 'Offset to bitmap bits
+ pbih.biClrUsed*SIZEOF(RGBQUAD)
hdr.bfSize = hdr.bfOffBits + pbih.biSizeImage 'Size of entire file
hdr.bfReserved1 = 0
hdr.bfReserved2 = 0
'Create the .BMP file
'--------------------
hf = CreateFile (BYVAL STRPTR(sFile), %GENERIC_READ OR _
%GENERIC_WRITE, 0, BYVAL %NULL, _
%CREATE_ALWAYS, _
%FILE_ATTRIBUTE_NORMAL, %NULL)
IF hf = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION
'Copy BITMAPFILEHEADER into .BMP file
'------------------------------------
IF 0 = WriteFile (hf, hdr, SIZEOF(hdr),_
dwTmp, BYVAL %NULL) THEN GOTO CloseBMP
'Copy the BITMAPINFOHEADER into the file
'---------------------------------------
IF 0 = WriteFile (hf, pbih, SIZEOF(pbih),_
dwTmp, BYVAL %NULL) THEN GOTO CloseBMP
'Copy the RGBQUAD array into the file
'------------------------------------
IF pbih.biClrUsed THEN
IF 0 = WriteFile (hf, pbi.bmiColors, pbih.biClrUsed*SIZEOF(RGBQUAD), _
dwTmp, BYVAL %NULL) THEN GOTO CloseBMP
END IF
'Copy the bitmap bits into the file
'----------------------------------
dwTotal = pbih.biSizeImage
cb = dwTotal
hp = STRPTR(lpBits)
WHILE cb > %MAXWRITE
IF 0 = WriteFile (hf, BYVAL hp, %MAXWRITE,_
dwTmp, BYVAL %NULL) THEN GOTO CloseBMP
cb = cb - %MAXWRITE
hp = hp + %MAXWRITE
WEND
IF 0 = WriteFile (hf, BYVAL hp, cb, dwTmp, BYVAL %NULL) THEN GOTO CloseBMP
iRet = %TRUE
'Close the .BMP file
'-------------------
CloseBMP:
CALL CloseHandle (hf)
FUNCTION = iRet
END FUNCTION
صفحه اصلی
انجمن
جستجو
فهرست اعضا
افزونه های فایرفاکس
» 
تشکر شده توسط :
کم کم باید جامون رو بدیم به جوونا 