codemaster » 01.06.2005 (Ср) 11:38
Konst_One » 01.06.2005 (Ср) 11:45
Konst_One » 01.06.2005 (Ср) 11:51
Option Explicit
Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public Enum FileFormat
ffGIF
ffBMP
End Enum
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Type GifProcInfo
hBMP As Long
FileName As String
hdc As Long
Width As Long
Height As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
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 Type
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
Const GIF87a = "GIF87a"
Const GIF89a = "GIF89a"
Const GifTerminator As Byte = &H3B
Const ImageSeparator As Byte = &H2C
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SRCINVERT = &H660046 ' (DWORD) dest = source XOR dest
Private Const BI_RGB = 0&
Private Const BI_RLE8 = 1&
Const CHAR_BIT = 8
Const CodeSize As Byte = 9 ' Code size used for all codes
Const ClearCode = 256 '
Const EndCode As Integer = 257 ' End of data marker
' We emit a clear code after every LastCode - FirstCode + 1 data values
' have been written
Const FirstCode = 258
Const LastCode As Integer = 511
Enum GIFFormat
gf256Color = &HF7 '256-color gif with global color map
End Enum
Enum ImageFormat
ifGlobalNonInterlaced = &H7 ' image using global color map (non-interlaced bit sequence)
ifLocalNonInterlaced = &H87 ' local color map (non interlaced)
End Enum
Public Type SIZEL
cx As Long
cy As Long
End Type
Private Type GifHeader
sSignature As String * 3
sVersion As String * 3
End Type
Type GifScreenDescriptor
logical_screen_width As Integer
logical_screen_height As Integer
flags As Byte 'FileFormat
background_color_index As Byte
pixel_aspect_ratio As Byte
End Type
Type GifImageDescriptor
Left As Integer
Top As Integer
Width As Integer
Height As Integer
Format As Byte 'ImageFormat
End Type
Public Type GIFPALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
End Type
Public Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
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 BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private colTable As New Collection
Private fn As Integer
Private arPalette(255) As GIFPALETTEENTRY
Private iLastColor As Integer
Private arImage() As Byte
Private bit_position As Integer
Private code_count As Integer
Private data_buffer(255) As Byte
Private aPower2(31) As Long
Public Busy As Boolean 'флажок занятости
Public Info As GifProcInfo
Public threadid As Long
Public Function SaveGIF(gpi As GifProcInfo) As Boolean
If Busy = True Then Exit Function
Busy = True
Dim bi As BITMAPINFO
With bi.bmiHeader
.biSize = Len(bi.bmiHeader)
.biWidth = gpi.Width 'WidthSrc
.biHeight = gpi.Height ' HeightSrc
.biPlanes = 1
.biBitCount = 8
.biCompression = BI_RGB
End With
'-----------------------------------------
Dim ret As Long
Dim hMem As Long
Dim lpBits As Long
Dim hbmOld As Long
Dim buf() As Byte
Dim lLineLength As Long
ReDim buf(CLng(((gpi.Width + 3) \ 4) * 4), gpi.Height) As Byte
Dim i As Long
' Allocate memory for bitmap bits.
For i = 0 To gpi.Height - 1
ret = GetDIBits(gpi.hdc, gpi.hBMP, i, 1, buf(0, gpi.Height - i), bi, 0)
Next
fn = FreeFile
Dim scr As GifScreenDescriptor
' fills screen descriptor
scr.background_color_index = 0
scr.flags = gf256Color
scr.pixel_aspect_ratio = 0
Dim im As GifImageDescriptor
'fills image descriptor
im.Format = ifGlobalNonInterlaced
im.Height = gpi.Height
im.Left = 0
im.Top = 0
im.Width = gpi.Width
' initialization of gif palette
For i = 0 To 255
arPalette(i).peBlue = bi.bmiColors(i).rgbBlue
arPalette(i).peGreen = bi.bmiColors(i).rgbGreen
arPalette(i).peRed = bi.bmiColors(i).rgbRed
Next
' saves the file
Dim data As Byte
If FileExists(gpi.FileName) Then Kill gpi.FileName
Open gpi.FileName For Binary As fn
Put #fn, , GIF87a
Put #fn, , scr
Put #fn, , arPalette
Put #fn, , ImageSeparator
Put #fn, , im
data = CodeSize - 1
Put #fn, , data
data_buffer(0) = 0
bit_position = CHAR_BIT
Dim jj As Long
Dim ii As Long
Dim code As Integer
Dim code_str As String
Dim total As Double
total = gpi.Width * gpi.Height
For ii = 0 To gpi.Height - 1
Reinitialize
code_str = Format$(buf(0, ii), "000")
code = buf(0, ii)
On Error Resume Next
For jj = 1 To gpi.Width - 1
' find string
Dim cd As String * 3
cd = Format$(buf(jj, ii), "000")
code = colTable(code_str & cd)
code_str = code_str & cd
If Err <> 0 Then
If colTable.count = 253 Then
Reinitialize
End If
colTable.Add colTable.count + FirstCode, code_str
OutputBits code, CodeSize
code_str = cd
code = buf(jj, ii)
Err.Clear
End If
Next
OutputBits code, CodeSize
'передаем управление системе, чтоб совсем уж не отнимать ресурсы у других программ
'не после записи каждой строки картинки, а после каждой 10-й
If ii Mod 10 = 0 Then
DoEvents
End If
Next
OutputCode (EndCode)
For i = 0 To data_buffer(0)
Put #fn, , data_buffer(i)
Next
data = 0
Put #fn, , data
Put #fn, , GifTerminator
Close fn
Erase buf
SaveGIF = 0
Busy = False
End Function
Private Sub OutputBits(value As Integer, count As Integer)
'
' Description:
'
' This function writes a bit stream to the output buffer. Data is written
' in blocks of 0 to 255 bytes preceded by a count byte.
'
' Parameters:
' value: The value to output
' count: The number of bits to write
'
Dim ii As Integer
ii = 0
Do While ii < count
' See if we need to advance to the next byte position within the buffer.
If bit_position >= CHAR_BIT Then
' See if we need to move to the next buffer.
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
Dim bit As Integer
If (LShiftWord(1, ii) And value) <> 0 Then
bit = 1
Else
bit = 0
End If
data_buffer(data_buffer(0)) = LShiftWord(bit, bit_position) Or data_buffer(data_buffer(0))
bit_position = bit_position + 1
ii = ii + 1
Loop
End Sub
Private Sub OutputCode(code As Integer)
code_count = code_count + 1
If code_count > LastCode Then
' At this point we would have to increase the code length.
' Instead we put out a clear code to ensure that the code
' length remains at 9.
code_count = FirstCode
Call OutputBits(ClearCode, CodeSize)
ClearTable
End If
Call OutputBits(code, CodeSize)
End Sub
Private Sub ClearTable()
Dim i As Integer
For i = 1 To colTable.count
colTable.Remove 1
Next
End Sub
Private Sub Reinitialize()
ClearTable
Call OutputBits(ClearCode, CodeSize)
End Sub
Private Function FileExists(ByVal strPathName As String) As Boolean
Dim af As Long
af = GetFileAttributes(strPathName)
FileExists = (af <> -1)
End Function
Function Power2(ByVal i As Integer) As Long
If 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 LShiftWord(ByVal w As Integer, ByVal c As Integer) As Integer
'BugAssert c >= 0 And c <= 15
Dim dw As Long
dw = w * Power2(c)
If dw And &H8000& Then
LShiftWord = CInt(dw And &H7FFF&) Or &H8000
Else
LShiftWord = dw And &HFFFF&
End If
End FunctionDim a As GifProcInfo
a.FileName = App.Path + "\test.gif" 'Фаил куда сохранять
a.hBMP = Picture1.Image.Handle 'Picture1 содержит картинку
a.hdc = Picture1.hdc
a.Height = Picture1.ScaleHeight 'в пикселах
a.Width = Picture1.ScaleWidth 'в пикселах
'долго и мучительно сохраняем;)
me.MousePointer = 11
me.Enabled = False
SaveGIF a
me.MousePointer = 0
me.Enabled = True codemaster » 01.06.2005 (Ср) 12:56
cd = Format$(buf(jj, ii), "000")
code = colTable(code_str & cd)
code_str = code_str & cd
tyomitch » 01.06.2005 (Ср) 13:53
Konst_One писал(а):А вот пример кода на VB для сохранения в GIF
Правда немного медленый...
CODE
codemaster » 02.06.2005 (Чт) 11:35
kostyanet » 10.06.2006 (Сб) 14:12
codemaster писал(а):Доброе время суток
Итак в консольной проге есть указатель(handle) на
DIB - ( Device-independent bitmap) рисунка в памяти .
Требуется сохранить это чудо в jpg. tiff pcx
(вообщем в любой формат с компр. сейчас реализовано
сохранение в BMP)
tyomitch » 10.06.2006 (Сб) 14:22
codemaster писал(а):P.S. Вариант с GDI как и добавление новых DLL не приемлем по тех. заданию
Сейчас этот форум просматривают: AhrefsBot и гости: 52
