Сохранить рисунок через API функции. ( ОЧЕНЬ НУЖНО )

[ALX_2002]

Здраствуйте форумане. У меня к вам вопр - кто знает как созранить изображение из HDC на диск ?

P.S HDC - Создан через CreateCompatibleDc

Пробывал SavePicture - не нашёл как этой функции подсунуть HDC

[alibek]

А вывести на PictureBox и затем сохранить?

[ALX_2002]

Трабл то какой - У меня считай ни формы ни пикчербокса. Это всё в модуле. .

[GSerg]

Хм... Наверняка есть более красивый путь... Но раз срочно, то берём функцию... Где же она... Ага...

Код: Выделить всё

Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    'Create a compatible device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    'Select the compatible bitmap into our compatible device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'What's the size of that palette?
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Set the palette version
        LogPal.palVersion = &H300
        'Number of palette entries
        LogPal.palNumEntries = 256
        'Retrieve the system palette entries
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        'Create the palette
        hPal = CreatePalette(LogPal)
        'Select the palette
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        'Realize the palette
        R = RealizePalette(hDCMemory)
    End If

    'Copy the source image to our compatible device context
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Select the palette
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    'Delete our memory DC
    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function

Ну а там уже...

[ALX_2002]

О пасиб ! И возращает в виде PICTURE ! Супер, только функции CreateBitmapPicture у меня нету. А лан - в нете найду. Пасиб

[GSerg]

Код: Выделить всё

Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
        .hBmp = hBmp ' Handle to bitmap
        .hPal = hPal ' Handle to palette (may be null)
    End With

    'Create the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

    'Return the new picture
    Set CreateBitmapPicture = IPic
End Function

[ALX_2002]

Отец, всё бы здорово, кроме параметров

Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

1 - Pic As PicBmp - Создаётся на основе PICTUREBOX
2 - IID_IDispatch As GUID - Вообще не понятно как юзать - vb его не понимает



P.S Я тоже этот пример нашёл

[ALX_2002]

Да.. Я забыл напомнить в чём проблема - у меня же ни формы ни объектов нету. И поэтому я не могу создаватть as PicBmp...

[ALX_2002]

Сорри - был не прав. Совсем слепой стал на старости лет

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

[ALX_2002]

2 GSerg + all:

Народ, кто нибудь знает как настраивается GUID ???

'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

Я нигде не нашёл объяснения всех подставленных констат. Они чем нибудь обусловлены или всегда подставляются только эти значения ?

[GSerg]

У каждого интерфейса есть GUID. Он создаётся при создании любого нового COM-объекта и является неизменяемой константой, однозначно указывающей на интерфейс.
Строка GUID в общем случае имеет вид {xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}, где X - шестнадцатеричная цифра.
В данном случае приведён GUID интерфейса IDispath. Мы его инициализировали вручную. С тем же успехом мы могли скормить строку "{00020400-0000-0000-C000-000000000046}" функции IIDFromString.

Рекомендуется заценить мою маленькую статейку про работу с интерфейсами на www.vbstreets.ru

[ALX_2002]

2 GSerg:
1) Прочитал
2) Исправил пару багов в DLL

3) Ещё один вопр, наверное уже последний -

При сжатии DLLой изображения портится цвет. Т.е добавляются какие то странные пиксели. Похоже, что палитра становится 16 битной или 256 цветной. Я весь в сомнениях на что грешить. Подозреваю:

1) Параметр hpal
2) При формировании картинки через OleCreatePictureIndirect я опять же даю какие то не те параметры.
3) Глюк с созранением через SavePicture

[ALX_2002]

to GSerg: Отец, я так понял только ты знаешь как мне сделать так чтобы палитра не портилась. . Подскажи - что настраивать ?

P.S Ого... Это моё 666 сообщение....Мда ну и денёк..

[GSerg]

Погодь чуток
Я ж просто из апигайда пример взял. Вот почитаю msdn, тогда скажу что-то связное

[ALX_2002]

Отец... Только на тебя вся надежда !!!

[GSerg]

Да там такая муть с этой палитрой, я не понял ни фига

Скажи мне, а почему нельзя заюзать переменную

Код: Выделить всё

dim p as ipicturedisp
set p=loadpicture("file")

,после чего работать с объектом p? p.handle - это битмап и есть. Его даже можно в DC выбрать.

[ALX_2002]

Дык, я разве сказал что нельзя ???? Я уже давно так и сделал !

У меня на нём всё и пашет. Один тока трабл - оказывается весь рисунок при сжатии херит функция StretchBlt

Короче я сейчас собиру пример и выложу сюда.

Вдруг поможет.

[ALX_2002]

Вот оно

[GSerg]

Разберёмся...
Сохраняет-то в bmp, ты в курсе?

[ALX_2002]

2 Gserg: УРА ! Получилось. Оказалось надо было перед копированием из DcNormal в DcStretched вызвать

Код: Выделить всё

Call SetStretchBltMode(DCStretched, 3)

Тогда качество никак не портится.

На счёт того что сейвится в BMP эт я заметил . Ну точнее он сейвит с любым расширением, но тип записи у него как в BMP файл. Т.е считай пишет всю битовую мапу в файл.

Если научишь сейвить в GIF или в JPG буду оч благодарен

[GSerg]

Гы
Где-то я тут выкладывал...
http://bbs.vbstreets.ru/viewtopic.php?p=22148#22148

[A.A.Z.]

А почему сохранение не пашет? Нажимаешь "Сохранить" - ничего - файл не появляется...

[ALX_2002]

2 Gserg: Отец... Можешь мне объяснить, как этим "танком" пользоваться. Он у меня как и Smart-а ругается на функцию. Наверное на ту же.

Код: Выделить всё

KeyName = Space$(MAX_SIZE)

Чего делать то ?

[GSerg]

А вот тут ничего сказать не могу, у меня работает. Танк, впрочем, совершенно не мой, и как работает, не знаю.