Save Pictures

[Naima]

Привет всем !

Подскажите мне пожалуйста как изображение нарисованное в PictureBox сохранить в BMP файле ? ну тоесть создать под него файл и загнать туды картинку. Во :)

[man2D]

Есть такая штука, OpenDialog. Вот она и отвечает за функцию сохранения/открытия файлов. Цитировать мануал не буду - это глупо.

Изменено 30 марта, 2004 пользователем man2D

[Naima]

man2D

Мне хочется узнать как сохранять в файлах в формате bmp то что нарисовано допустим в picturebox'e. (речь о VB6)

Изменено 1 апреля, 2004 пользователем Naima

[Xcom]

B) Ну вопщем есть такие команды как, LoadPicture() и SavePicture().

Принцип использования:

MoiRisunok.Picture = LoadPicture(NazvanijeFila)

NazvanijeFila - BMP, GIF, JPG ну и тд....

если LoadPicture() без аргумента работает наподобе Cls :D

SavePicture MoiRisunok.Picture, "C:\Moirisunok.bmp"

если не указать AutoRedraw равно True, файл будет пустым. :)

Этим способом можно сохранять только в BMP тип. :)

[Naima]

Xcom

спасибо , с этим понятно :)

а вот рамки рисунка (тоесть размеры) будут теми же что наваяли в picturebox ?

... гы , все оказывается проще чем думалось !

[Xcom]

Рисунок с формой (в битовом виде) хранится в фвйлах frx. :) думаю свойство picture должно возвращять с всеми примочками на рисунке. :)

[Gray Angel]

А вот пример кода на VB для сохранения в GIF

Правда немного медленый...

Option ExplicitType RGBQUAD       rgbBlue As Byte       rgbGreen As Byte       rgbRed As Byte       rgbReserved As ByteEnd TypePublic Enum FileFormat ffGIF ffBMPEnd EnumPrivate Type SECURITY_ATTRIBUTES       nLength As Long       lpSecurityDescriptor As Long       bInheritHandle As LongEnd TypeType GifProcInfo hBMP As Long FileName As String hdc As Long Width As Long Height As LongEnd TypeType RECT       Left As Long       Top As Long       Right As Long       Bottom As LongEnd TypePrivate Type BITMAPFILEHEADER       bfType As Integer       bfSize As Long       bfReserved1 As Integer       bfReserved2 As Integer       bfOffBits As LongEnd TypeType 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 LongEnd TypeType BITMAPINFO       bmiHeader As BITMAPINFOHEADER       bmiColors(255) As RGBQUADEnd TypeConst GIF87a = "GIF87a"Const GIF89a = "GIF89a"Const GifTerminator As Byte = &H3BConst ImageSeparator As Byte = &H2CPrivate Const SRCCOPY = &HCC0020 ' (DWORD) dest = sourcePrivate Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR destPrivate Const BI_RGB = 0&Private Const BI_RLE8 = 1&Const CHAR_BIT = 8Const CodeSize As Byte = 9 ' Code size used for all codesConst 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 writtenConst FirstCode = 258Const LastCode As Integer = 511Enum GIFFormatgf256Color = &HF7 '256-color gif with global color mapEnd EnumEnum ImageFormat ifGlobalNonInterlaced = &H7 ' image using global color map (non-interlaced bit sequence) ifLocalNonInterlaced = &H87 ' local color map (non interlaced)End EnumPublic Type SIZEL   cx As Long   cy As LongEnd TypePrivate Type GifHeader sSignature As String * 3 sVersion As String * 3End TypeType GifScreenDescriptor logical_screen_width As Integer logical_screen_height As Integer flags As Byte 'FileFormat background_color_index As Byte pixel_aspect_ratio As ByteEnd TypeType GifImageDescriptor Left As Integer Top As Integer Width As Integer Height As Integer Format As Byte 'ImageFormatEnd TypePublic Type GIFPALETTEENTRY peRed As Byte peGreen As Byte peBlue As ByteEnd TypePublic Type PALETTEENTRY       peRed As Byte       peGreen As Byte       peBlue As Byte       peFlags As ByteEnd TypePrivate 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 LongPrivate Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As LongPrivate 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 LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private colTable As New CollectionPrivate fn As IntegerPrivate arPalette(255) As GIFPALETTEENTRYPrivate iLastColor As IntegerPrivate arImage() As BytePrivate bit_position As IntegerPrivate code_count As IntegerPrivate data_buffer(255) As BytePrivate aPower2(31) As LongPublic Busy As Boolean  'флажок занятостиPublic Info As GifProcInfoPublic threadid As Long  Public Function SaveGIF(gpi As GifProcInfo) As BooleanIf 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 = FalseEnd FunctionPrivate 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 LoopEnd SubPrivate 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 SubPrivate Sub ClearTable() Dim i As Integer For i = 1 To colTable.count   colTable.Remove 1 NextEnd SubPrivate Sub Reinitialize() ClearTable Call OutputBits(ClearCode, CodeSize)End SubPrivate Function FileExists(ByVal strPathName As String) As Boolean Dim af As Long af = GetFileAttributes(strPathName) FileExists = (af <> -1)End FunctionFunction 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 FunctionFunction LShiftWord(ByVal w As Integer, ByVal c As Integer) As Integer   'BugAssert c >= 0 And c <= 15   Dim dw As Long   dw = w * Power2©   If dw And &H8000& Then       LShiftWord = CInt(dw And &H7FFF&) Or &H8000   Else       LShiftWord = dw And &HFFFF&   End IfEnd Function

Использование:

Dim a As GifProcInfoa.FileName = App.Path + "\test.gif" 'Фаил куда сохранятьa.hBMP = Picture1.Image.Handle   'Picture1  содержит картинкуa.hdc = Picture1.hdca.Height = Picture1.ScaleHeight 'в пикселахa.Width = Picture1.ScaleWidth   'в пикселах'долго и мучительно сохраняем;)me.MousePointer = 11me.Enabled = FalseSaveGIF ame.MousePointer = 0me.Enabled = True

[SavSoft]

What should I do? When I call SavePicture() I occasionally get an error "Invalid property value". I've tried 3 times - the same result. But when I had been writing the message I had no error. What has happen?

[Yezhishe]

At first - author of the previous post been here last time 4 years ago... So I think - nobody could answer your question...

P.S. Preferred language here is Russian...