Массив и картинка

[Demonx]

Как из массива байтов картинки нарисовать на Picture1?

[keks-n]

Для каждого рикселя сделать PSet

[Demonx]

Знаю что у обёртки GDI+ есть функция CreateImageFromMemory, но не не хочу её с собой таскать из-за одной функции

[GSerg]

http://bbs.vbstreets.ru/viewtopic.php?t=18359

[Demonx]

Из примера:

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

SetDIBitsToDevice Me.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS

А если я не знаю высоту и ширину картинки? Как быть? Есть байтовый массив и всё. Можно поконкретней пример?
Спасибо.

[GSerg]

А что в буфере? Чисто данные рисунка, без заголовка и описания размеров?
Тогда никак, ибо можно сделать прямоугольник более чем одним способом.

[Andrey Fedorov]

А если я не знаю высоту и ширину картинки? Как быть? Есть байтовый массив и всё. Можно поконкретней пример?

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

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long
Private Declare Function IsEqualGUID Lib "ole32" (rguid1 As GUID, rguid2 As GUID) As Boolean

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As CBoolean, ppstm As Any) As Long

Private Const GMEM_MOVEABLE = &H2
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Private Enum CBoolean   ' enum members are Long data types
    CFalse = 0
    CTrue = 1
End Enum

Private Type GUID       ' 16 bytes (128 bits)
    dwData1 As Long     ' 4 bytes
    wData2 As Integer   ' 2 bytes
    wData3 As Integer   ' 2 bytes
    abData4(7) As Byte  ' 8 bytes, zero based
End Type

Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As CBoolean, riid As GUID, ppvObj As Any) As Long

Public Function PictureFromBits(abPic() As Byte) As IPicture  ' not a StdPicture!!
    Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
    Const S_OK = 0     ' indicates successful HRESULT
   
    Dim nLow As Long
    Dim cbMem  As Long
    Dim hMem  As Long
    Dim lpMem  As Long
    Dim IID_IPicture As GUID
    Dim istm As stdole.IUnknown '  IStream
    Dim ipic As IPicture
   
    ' Get the size of the picture's bits
    On Error GoTo Out
    nLow = LBound(abPic)
    On Error GoTo 0
    cbMem = (UBound(abPic) - nLow) + 1
 
    ' Allocate a global memory object
    hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
    If hMem Then
        ' Lock the memory object and get a pointer to it.
        lpMem = GlobalLock(hMem)
        If lpMem Then
            ' Copy the picture bits to the memory pointer and unlock the handle.
            MoveMemory ByVal lpMem, abPic(nLow), cbMem
            GlobalUnlock hMem
            ' Create an ISteam from the pictures bits (we can explicitly free hMem
            ' below, but we'll have the call do it here...)
            If (CreateStreamOnHGlobal(hMem, CTrue, istm) = S_OK) Then
                If (CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture) = S_OK) Then
                    ' Create an IPicture from the IStream (the docs say the call does not
                    ' AddRef its last param, but it looks like the reference counts are correct..)
                    OleLoadPicture ByVal ObjPtr(istm), cbMem, CFalse, IID_IPicture, PictureFromBits
                End If   ' CLSIDFromString
            End If   ' CreateStreamOnHGlobal
        End If   ' lpMem
        GlobalFree hMem
    End If   ' hMem
   
Out:
End Function

[Demonx]

Спасибо, работает!

[tyomitch]

А если я не знаю высоту и ширину картинки? Как быть? Есть байтовый массив и всё. Можно поконкретней пример?

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

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long
Private Declare Function IsEqualGUID Lib "ole32" (rguid1 As GUID, rguid2 As GUID) As Boolean

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As CBoolean, ppstm As Any) As Long

Private Const GMEM_MOVEABLE = &H2

...

End Function

Каждый раз, когда будут постить этот код, я буду ругаться на использование GMEM_MOVEABLE + GlobalLock + GlobalUnlock там, где хватило бы обычного GMEM_FIXED

[Demonx]

А можно полностью пример?))

[tyomitch]

Ну, например, так:

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

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long
Private Declare Function IsEqualGUID Lib "ole32" (rguid1 As GUID, rguid2 As GUID) As Boolean

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long

'Private Const GMEM_FIXED = &H0
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Private Type GUID       ' 16 bytes (128 bits)
    dwData1 As Long     ' 4 bytes
    wData2 As Integer   ' 2 bytes
    wData3 As Integer   ' 2 bytes
    abData4(7) As Byte  ' 8 bytes, zero based
End Type

Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As GUID, ppvObj As Any) As Long

Public Function PictureFromBits(abPic() As Byte) As IPicture  ' not a StdPicture!!
    Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
    Const S_OK = 0     ' indicates successful HRESULT
   
    Dim nLow As Long
    Dim cbMem  As Long
    Dim lpMem  As Long
    Dim IID_IPicture As GUID
    Dim istm As stdole.IUnknown '  IStream
    Dim ipic As IPicture
   
    ' Get the size of the picture's bits
    On Error GoTo Out
    nLow = LBound(abPic)
    On Error GoTo 0
    cbMem = (UBound(abPic) - nLow) + 1
 
    ' Allocate a global memory object
    lpMem = GlobalAlloc(0, cbMem)
    If lpMem Then
            ' Copy the picture bits to the memory pointer
            MoveMemory ByVal lpMem, abPic(nLow), cbMem
            ' Create an ISteam from the pictures bits (we can explicitly free hMem
            ' below, but we'll have the call do it here...)
            If (CreateStreamOnHGlobal(lpMem, 1, istm) = S_OK) Then
                If (CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture) = S_OK) Then
                    ' Create an IPicture from the IStream (the docs say the call does not
                    ' AddRef its last param, but it looks like the reference counts are correct..)
                    OleLoadPicture ByVal ObjPtr(istm), cbMem, 0, IID_IPicture, PictureFromBits
                End If   ' CLSIDFromString
            End If   ' CreateStreamOnHGlobal
    End If   ' lpMem
    GlobalFree lpMem
   
Out:
End Function

[kif]

tyomitch
Если не сложно, можно пример как сделать наоборот, т.е. из picture в Array

[Andrey Fedorov]

tyomitch
Если не сложно, можно пример как сделать наоборот, т.е. из picture в Array

А как насчет взять его обертку и не мучиться?

Ну или вот этот контрол: http://atalasoft.com/products/imgxcontrols/

[kif]

Мне нужны только эти 2 метода picture2Array и Array2picture. больше ничего. обертка у меня есть, но она весит....

[Andrey Fedorov]

Мне нужны только эти 2 метода picture2Array и Array2picture. больше ничего. обертка у меня есть, но она весит....

Ты начал с одного.
Ну а дальше будешь входить во вкус все больше и больше...

[kif]

Может быть.

[Andrey Fedorov]

:-) Может быть.

Ну и пользуй обертку или контрол - они многое умеют и не мучайся.

[ANDLL]

Кстати, Артём, кажеться кто-то не рекомендует юзать GlobalAlloc? Может следует его на HeapAlloc(GetProcessHeap) заменить?

[GSerg]

Хм...

Вот ты, ANDLL, сказал об этом... было уж хотел тебе сказать - а позырь, друг мой, внимательно на имя функции CreateStreamOnHGlobal, но таки полез в MSDN на всякий случай...

Так там, Тёмыч, таки написано, что

hGlobal
[in] Memory handle allocated by the GlobalAlloc function. The handle must be allocated as movable and nondiscardable.

Так что ты не прав

[ANDLL]

Кстати, GlobalAlloc таки вызывает HeapAlloc

[tyomitch]

Хм...

Вот ты, ANDLL, сказал об этом... было уж хотел тебе сказать - а позырь, друг мой, внимательно на имя функции CreateStreamOnHGlobal, но таки полез в MSDN на всякий случай...

Так там, Тёмыч, таки написано, что

hGlobal
[in] Memory handle allocated by the GlobalAlloc function. The handle must be allocated as movable and nondiscardable.

Так что ты не прав

1) Чен сказал, что так можно
2) Так работает
3) Нет никакой причины, почему это могло бы не работать
4) Документация, видимо, относится также и к OLE в Win16; код, использующий GMEM_MOVEABLE, работал бы в обоих платформах.

[Antonariy]

kif, поищи "Развернем обертки!"

[kibernetics]

Не хотелось бы флудить, посему спрошу тута. Может кто-нить видел реализацию отображения точек с различными спецэффектами? Тобишь, типа постепенного появления поточечно(растворение наоборот), или смещение от краёв, плавные переходы... и другое в том же духе.

[BV]

http://www.vb.kiev.ua/code/graph/Transi ... ffects.zip

[kibernetics]

BV
уважуха и респект

[kibernetics]

хочу научится читать в массив картинку, и полагаю, что нижеприведённый код должен мне помочь, но как использовать этот код в акцесе:

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

Option Explicit

Private Const BlockSize = 32768

Function ReadBLOB(Source As String, T As Recordset, sField As String)
    Dim NumBlocks As Integer 'счётчик количества блоков
    Dim SourceFile As Integer
    Dim i As Integer
    Dim FileLength As Long
    Dim LeftOver As Long
    Dim byteData() As Byte

    On Error GoTo Err_ReadBLOB 'если ошибка, то надо перейти на обработчик ошибок

    SourceFile = FreeFile
    Open Source For Binary Access Read As SourceFile 'открытие файла

    'получение длинны файла
    FileLength = LOF(SourceFile)
    If FileLength = 0 Then
    ReadBLOB = 0
    Exit Function
    End If

    'вычисление кол-во блоков, которые будут записаны в базу
    NumBlocks = FileLength \ BlockSize
    LeftOver = FileLength Mod BlockSize 'вычисляем остаток

    If LeftOver > 0 Then 'если есть остаток, то запись из файла в базу
                         'данных с размером остатка

    ReDim byteData(0 To LeftOver - 1) 'изменение массива для считывания данных
    Get SourceFile, , byteData 'считывание данных из файла
    'T.Edit
    T(sField).AppendChunk (byteData) 'запись в базу
    'T.Update
    End If

    'записываем данные блоками, размером BlockSize
    ReDim byteData(0 To BlockSize - 1)
    For i = 1 To NumBlocks 'считывание и запись в базу
    Get SourceFile, , byteData 'считывание данных из файла
    T(sField).AppendChunk (byteData) 'запись в базовое поле
    Next i

    Close SourceFile
    ReadBLOB = FileLength 'возвращение функцией размер записанных данных
    Exit Function

    Err_ReadBLOB:
     ReadBLOB = -Err 'возвращение номера ошибки
    MsgBox Err.Description, , Err.Number 'если нужно - сообщение об ошибке
    Exit Function

    End Function

    Function WriteBLOB(T As Recordset, sField As String, Destination As String)
    Dim NumBlocks As Integer, DestFile As Integer, i As Integer
    Dim FileLength As Long, LeftOver As Long
    Dim byteData() As Byte
   
    On Error GoTo Err_WriteBLOB
   
    'размер записанных данных
    FileLength = T(sField).FieldSize()
    If FileLength = 0 Then
    WriteBLOB = 0
    Exit Function
    End If

    'вычисление количества блоков для записи
    NumBlocks = FileLength \ BlockSize
    LeftOver = FileLength Mod BlockSize
   
    'очистка содержимого файла
    DestFile = FreeFile
    Open Destination For Output As DestFile
    Close DestFile

    'открытие файла
    Open Destination For Binary As DestFile
   
    'если есть остаток, то запись в файл данных из базы с размером остатка
    If LeftOver > 0 Then
    byteData() = T(sField).GetChunk(0, LeftOver)
    Put DestFile, , byteData
    End If

    'запись в файл всех данных, которые остались блоками размером
    ' по BlockSize каждый
    For i = 1 To NumBlocks
    byteData() = T(sField).GetChunk((i - 1) * BlockSize + LeftOver, BlockSize)
    Put DestFile, , byteData
    Next i
    Close DestFile
    WriteBLOB = FileLength
    Exit Function

    Err_WriteBLOB:
    WriteBLOB = -Err
    MsgBox Err.Description, vbCritical, Err.Number
    Exit Function

    End Function



я пытаюсь прикрутить к кнопке:

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

Private Sub Кнопка6_Click()
    ReadBLOB("e:\temp\pictures\table.gif", main, Pict)
End Sub

но выскакивает ошибка типа Syntax Error или Excepted =

как правильно использовать код-то?

[keks-n]

Скобки убери.

[kibernetics]

keks-n
скобки я убрал, не правильно написал.

Функция ReadBlob возвращает количество байт, записанных в базе данных. Source - файл рисунка который, будет записан в базе, T - таблица, или запрос в поле которого будет добавлен файл рисунка, sField - имя Поля, таблицы (Т), для записи данных (в поле с этим именем будет cделана запись).

Pict заключил в кавычки, т.к. стринг. а вот как передать таблицу(рекордсет) не понимаю.
у меня есть таблица main, в ней есть поле Pict, тип поля OLE...[/code]

[kibernetics]

Чуть сдвинулся с места и уже залез в обработку функции, но опять проблемка выходит:
Когда время приходит вносить запись в базу:


выскакивает ошибка:


блин, запарился уже, не проходит, как я понимаю. редактирование поля. подскажите, что нужно сделать, чтоб массив вписался в поле.

[alibek]

Ты через DAO работаешь?