VB中实现BMP>GIF一Option Explicit '===VB中实现BMP > GIF== Private Type RGBTRIPLE rgbRed As Byte rgbGreen As Byte rgbBlue As Byte End TypePrivate Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End TypePrivate Type BITMAPINFOHEADER '40 bytes biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End TypePrivate Type BITMAPINFO256 bmiHeader As BITMAPINFOHEADER bmiColors(0 To 255) As RGBQUAD End TypePrivate Type BITMAP '14 bytes bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End TypePrivate Const BI_RGB = 0&Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO256, ByVal wUsage As Long) As Long Private Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDc As Long, pBitmapInfo As BITMAPINFO256, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long Private Const DIB_RGB_COLORS = 0Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long '============================GIF STAFF================Private Type GifScreenDes criptor logical_screen_width As Integer logical_screen_height As Integer flags As Byte background_color_index As Byte pixel_aspect_ratio As Byte End TypePrivate Type GifImageDes criptor Left As Integer Top As Integer Width As Integer Height As Integer Format As Byte 'ImageFormat End TypeConst GIF87a = "GIF87a" Const GifTerminator As Byte = &H3B Const ImageSeparator As Byte = &H2C Const CHAR_BIT = 8 Const CodeSize As Byte = 9 Const ClearCode = 256 Const EndCode As Integer = 257 Const FirstCode = 258 Const LastCode As Integer = 511 以上代码来自： SourceCode Explorer(源代码数据库) 复制时间： 2002-08-15 11:46:24 当前版本： 1.0.725 软件作者： Shawls 个人主页： Http://Shawls.Yeah.Net E-Mail： [email protected] QQ： 9181729 VB中实现BMP>GIF二Const MAX_CODE = LastCode - FirstCodePrivate colTable As New Collection Private fn As Integer Private gifPalette(0 To 255) As RGBTRIPLE Private bit_position As Integer Private code_count As Integer Private data_buffer(255) As Byte Private aPower2(31) As Long Private picWidth As Long, picHeight As Long Private IsBusy As Boolean Public Event Progress(ByVal Percents As Integer)Public Function SaveGIF(ByVal pic As StdPicture, ByVal sFileName As String, Optional hDc As Long = 0) As Boolean If IsBusy Then Exit Function Dim scr As GifScreenDes criptor, im As GifImageDes criptor Dim bi As BITMAPINFO256, bm As BITMAP Dim hDCScn As Long, OldObj As Long, Src_hDc As Long Dim hDib256 As Long, hDC256 As Long, OldObj256 As Long Dim buf() As Byte, data As Byte Dim I As Long, J As Long Dim intCode As Integer, nCount As Integer Dim sPrefix As String, sByte As String Dim tempPic As StdPicture IsBusy = True 'get image size and allocate buffer memory Call GetObjectAPI(pic, Len(bm), bm) picWidth = bm.bmWidth picHeight = bm.bmHeight ReDim buf(CLng(((picWidth + 3) \ 4) * 4), picHeight) As Byte 'Prepare DC for paintings hDCScn = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&) hDC256 = CreateCompatibleDC(hDCScn) If hDc = 0 Then Src_hDc = CreateCompatibleDC(hDCScn) OldObj = SelectObject(Src_hDc, pic) Else Src_hDc = 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 depth 'If you want advanced color manipulation with web-safe palettes or 'optimal palette with the specified number of colors using octree 'quantisation, visit http://vbaccelerator.com/codelib/gfx/octree.htmIf bm.bmBitsPixel <> 8 Then hDib256 = CreateDib256(hDC256, bi) If hDib256 <> 0 Then OldObj256 = SelectObject(hDC256, hDib256) Call BitBlt(hDC256, 0, 0, picWidth, picHeight, Src_hDc, 0, 0, vbSrcCopy) For I = 0 To picHeight - 1 Call GetDIBits(hDC256, hDib256, I, 1, buf(0, picHeight - I), bi, 0) Next Else With bi.bmiHeader .biSize = Len(bi.bmiHeader) .biWidth = picWidth .biHeight = picHeight .biPlanes = 1 .biBitCount = 8 .biCompression = BI_RGB End With For I = 0 To picHeight - 1 Call GetDIBits(Src_hDc, pic, I, 1, buf(0, picHeight - I), bi, 0) Next End If For I = 0 To 255 gifPalette(I).rgbBlue = bi.bmiColors(I).rgbBlue gifPalette(I).rgbGreen = bi.bmiColors(I).rgbGreen gifPalette(I).rgbRed = bi.bmiColors(I).rgbRed Next fn = FreeFile scr.background_color_index = 0 scr.flags = &HF7 '256-color gif with global color map scr.pixel_aspect_ratio = 0
'===VB中实现BMP > GIF==
Private Type RGBTRIPLE
rgbRed As Byte
rgbGreen As Byte
rgbBlue As Byte
End TypePrivate Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End TypePrivate Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End TypePrivate Type BITMAPINFO256
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 255) As RGBQUAD
End TypePrivate Type BITMAP '14 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End TypePrivate Const BI_RGB = 0&Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO256, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDc As Long, pBitmapInfo As BITMAPINFO256, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Const DIB_RGB_COLORS = 0Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
'============================GIF STAFF================Private Type GifScreenDes criptor
logical_screen_width As Integer
logical_screen_height As Integer
flags As Byte
background_color_index As Byte
pixel_aspect_ratio As Byte
End TypePrivate Type GifImageDes criptor
Left As Integer
Top As Integer
Width As Integer
Height As Integer
Format As Byte 'ImageFormat
End TypeConst GIF87a = "GIF87a"
Const GifTerminator As Byte = &H3B
Const ImageSeparator As Byte = &H2C
Const CHAR_BIT = 8
Const CodeSize As Byte = 9
Const ClearCode = 256
Const EndCode As Integer = 257
Const FirstCode = 258
Const LastCode As Integer = 511
以上代码来自： SourceCode Explorer(源代码数据库)
复制时间： 2002-08-15 11:46:24
当前版本： 1.0.725
软件作者： Shawls
个人主页： Http://Shawls.Yeah.Net
E-Mail： [email protected]
QQ： 9181729
VB中实现BMP>GIF二Const MAX_CODE = LastCode - FirstCodePrivate colTable As New Collection
Private fn As Integer
Private gifPalette(0 To 255) As RGBTRIPLE
Private bit_position As Integer
Private code_count As Integer
Private data_buffer(255) As Byte
Private aPower2(31) As Long
Private picWidth As Long, picHeight As Long
Private IsBusy As Boolean
Public Event Progress(ByVal Percents As Integer)Public Function SaveGIF(ByVal pic As StdPicture, ByVal sFileName As String, Optional hDc As Long = 0) As Boolean
If IsBusy Then Exit Function
Dim scr As GifScreenDes criptor, im As GifImageDes criptor
Dim bi As BITMAPINFO256, bm As BITMAP
Dim hDCScn As Long, OldObj As Long, Src_hDc As Long
Dim hDib256 As Long, hDC256 As Long, OldObj256 As Long
Dim buf() As Byte, data As Byte
Dim I As Long, J As Long
Dim intCode As Integer, nCount As Integer
Dim sPrefix As String, sByte As String
Dim tempPic As StdPicture
IsBusy = True
'get image size and allocate buffer memory
Call GetObjectAPI(pic, Len(bm), bm)
picWidth = bm.bmWidth
picHeight = bm.bmHeight
ReDim buf(CLng(((picWidth + 3) \ 4) * 4), picHeight) As Byte
'Prepare DC for paintings
hDCScn = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
hDC256 = CreateCompatibleDC(hDCScn)
If hDc = 0 Then
Src_hDc = CreateCompatibleDC(hDCScn)
OldObj = SelectObject(Src_hDc, pic)
Else
Src_hDc = 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 depth
'If you want advanced color manipulation with web-safe palettes or
'optimal palette with the specified number of colors using octree
'quantisation, visit http://vbaccelerator.com/codelib/gfx/octree.htmIf bm.bmBitsPixel <> 8 Then hDib256 = CreateDib256(hDC256, bi)
If hDib256 <> 0 Then
OldObj256 = SelectObject(hDC256, hDib256)
Call BitBlt(hDC256, 0, 0, picWidth, picHeight, Src_hDc, 0, 0, vbSrcCopy)
For I = 0 To picHeight - 1
Call GetDIBits(hDC256, hDib256, I, 1, buf(0, picHeight - I), bi, 0)
Next
Else
With bi.bmiHeader
.biSize = Len(bi.bmiHeader)
.biWidth = picWidth
.biHeight = picHeight
.biPlanes = 1
.biBitCount = 8
.biCompression = BI_RGB
End With
For I = 0 To picHeight - 1
Call GetDIBits(Src_hDc, pic, I, 1, buf(0, picHeight - I), bi, 0)
Next
End If
For I = 0 To 255
gifPalette(I).rgbBlue = bi.bmiColors(I).rgbBlue
gifPalette(I).rgbGreen = bi.bmiColors(I).rgbGreen
gifPalette(I).rgbRed = bi.bmiColors(I).rgbRed
Next
fn = FreeFile
scr.background_color_index = 0
scr.flags = &HF7 '256-color gif with global color map
scr.pixel_aspect_ratio = 0
im.Format = &H7 'GlobalNonInterlaced
im.Height = picHeight
im.Width = picWidth 以上代码来自： SourceCode Explorer(源代码数据库)
复制时间： 2002-08-15 11:46:32
当前版本： 1.0.725
软件作者： Shawls
个人主页： Http://Shawls.Yeah.Net
E-Mail： [email protected]
QQ： 9181729
去看看，那儿就有!