Load Image1(i) и Image1(i).Picture.Handle

[BlackSun]

При Load Image1(i) новые Image1(i) получают Picture.Handle такой же, как у начального Image1. Таким образом, весь массив Image1 указывает на одну картинку. Как создать массив Image1 с разными Picture.Handle, т.е. с отдельными изображениями (не в дизайнере) с зарезервированной областью данных под картинку?

[TheTrik]

Например OleCreatePictureIndirect
Вот примерResizeImage.rar (12,8 Кбайт, скачиваний: 222) , там идет изменение картинки в Image, но ты можешь использовать функцию Conv для конвертации в StdPicture

Сообщение отредактировано: TheTrik - 29.01.14, 12:56

[BlackSun]

можно было бы загружать картинку так Image1(i).Picture=LoadPicture(...), но не хочется вываливать файл и читать его. По сути, нужна ф-я CreatePicture(WidthPic, HeightPic, FillColor, ColorsInPixel) создающая пустышку Picture BMP.

[TheTrik]

Цитата BlackSun @ 29.01.14, 13:34

можно было бы загружать картинку так Image1(i).Picture=LoadPicture(...), но не хочется вываливать файл и читать его. По сути, нужна ф-я CreatePicture(WidthPic, HeightPic, FillColor, ColorsInPixel) создающая пустышку Picture BMP.

Я тебе дал пример где можно из GDI-растра получить StdPicture, а создать GDI растр через CreateCompatibleBitmap, CreateDIBSection в сети куча примеров.

[BlackSun]

похоже, создаётся BMP с 4-мя байтами на цвет, при копировании 3-х байтовый BMP искажается (видно, что закрашено 3/4 изображения). CopyDatBMP работает верно, т.к. если

     Set Image1(1).Picture = Conv(hBMP)

заменить на

     Set Image1(1).Picture = Image1(0).Picture

картинка нормальная.
Прикреплённый файлCreatePic.zip (2,96 Кбайт, скачиваний: 183)

Добавлено 01.02.14, 16:12
и ещё, чем IPictureDisp отличается от StdPicture?

Сообщение отредактировано: BlackSun - 01.02.14, 16:12

[TheTrik]

Option Explicit
 
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
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
 
Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
  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
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type
 
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc 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 GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (picDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
 
Private Function Conv(hBMP As Long) As StdPicture
    Dim Pic As PicBmp
    Dim IID_IDispatch As GUID
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    With Pic
       .Size = Len(Pic)
       .Type = vbPicTypeBitmap
       .hBMP = hBMP
       .hPal = 0
    End With
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, Conv
End Function
 
Private Sub Form_Load()
    Dim hBMP As Long, picDesc As BITMAP, BI As BITMAPINFO
    Load Image1(1)
    Image1(1).Move Image1(0).Left + Image1(0).Width + 60
    Image1(1).Visible = True
    hBMP = CreateCompatibleBitmap(Me.hdc, Image1(0).Width / Screen.TwipsPerPixelX, Image1(0).Height / Screen.TwipsPerPixelY)
    
    If hBMP <> 0 Then
        GetObject Image1(0).Picture.Handle, Len(picDesc), picDesc
        With BI.bmiHeader
            .biSize = Len(BI.bmiHeader)
            .biBitCount = picDesc.bmBitsPixel
            .biHeight = picDesc.bmHeight
            .biPlanes = picDesc.bmPlanes
            .biWidth = picDesc.bmWidth
        End With
        SetDIBits Me.hdc, hBMP, 0, picDesc.bmHeight, ByVal picDesc.bmBits, BI, 0
        Set Image1(1).Picture = Conv(hBMP)
    End If
 
End Sub

Добавлено 01.02.14, 16:50
Или так

Option Explicit
 
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
 
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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (picDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
 
Private Function Conv(hBMP As Long) As StdPicture
    Dim Pic As PicBmp
    Dim IID_IDispatch As GUID
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    With Pic
       .Size = Len(Pic)
       .Type = vbPicTypeBitmap
       .hBMP = hBMP
       .hPal = 0
    End With
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, Conv
End Function
 
Private Sub Form_Load()
    Dim hBMP As Long, DC As Long, obmp As Long, ip As IPicture
    Load Image1(1)
    Image1(1).Move Image1(0).Left + Image1(0).Width + 60
    Image1(1).Visible = True
    hBMP = CreateCompatibleBitmap(Me.hdc, Image1(0).Width / Screen.TwipsPerPixelX, Image1(0).Height / Screen.TwipsPerPixelY)
    If hBMP <> 0 Then
        Set ip = Image1(0).Picture
        DC = CreateCompatibleDC(Me.hdc)
        obmp = SelectObject(DC, hBMP)
        ip.Render DC, 0, 0, Image1(0).Width / Screen.TwipsPerPixelX, Image1(0).Height / Screen.TwipsPerPixelY, _
                     0, Image1(0).Picture.Height, Image1(0).Picture.Width, -Image1(0).Picture.Height, ByVal 0&
        SelectObject DC, obmp
        DeleteDC DC
        Set Image1(1).Picture = Conv(hBMP)
    End If
 
End Sub

[BlackSun]

не пойму, вынес первый вариант в ф-ю и увеличился размер картинки на выходе.

Private Function CopyPicBMP(hDC As Long, PicSource As StdPicture) As StdPicture
Dim hBMP As Long, picDesc As BITMAP, BI As BITMAPINFO
    hBMP = CreateCompatibleBitmap(hDC, PicSource.Width / Screen.TwipsPerPixelX, PicSource.Height / Screen.TwipsPerPixelY)
    If hBMP <> 0 Then
        GetObject PicSource.Handle, Len(picDesc), picDesc
        With BI.bmiHeader
            .biSize = Len(BI.bmiHeader)
            .biBitCount = picDesc.bmBitsPixel
            .biHeight = picDesc.bmHeight
            .biPlanes = picDesc.bmPlanes
            .biWidth = picDesc.bmWidth
        End With
        SetDIBits hDC, hBMP, 0, picDesc.bmHeight, ByVal picDesc.bmBits, BI, 0
        Set CopyPicBMP = Conv(hBMP)
    End If
End Function

[TheTrik]

PicSource.Width и PicSource.Height у тебя не Twip, а Himetric. Делай так

ScaleX(PicSource.Width,vbHimetric,vbPixels)

Аналогично по высоте

[BlackSun]

но ведь результат вычисления преобразуется в Long

Добавлено 01.02.14, 19:55
понял, с какого-то перепугу меняется их значение по другой системе

Сообщение отредактировано: BlackSun - 01.02.14, 19:55

[TheTrik]

Это разные системы координат, как сантиметры и дюймы

[BlackSun]

понятно, что разные. Значит, значения преобразуются при передаче объекта в функцию? А чем IPictureDisp отличается от StdPicture?

Добавлено 01.02.14, 20:14
после

        Set Image1(1).Picture = Conv(hBMP)

пишу для теста

        CopyDatBMP Image1(0).Picture, Image1(1).Picture

получаю мусор в картинке. Значит, структура заголовка BMP в Image1(0).Picture отлична от структуры в Image1(1).Picture...

Сообщение отредактировано: BlackSun - 01.02.14, 20:14

[TheTrik]

Цитата

А чем IPictureDisp отличается от StdPicture?

StdPicture - CoClass (компонентный класс), ты можешь создать объект StdPicture (например Set Z = New StdPicture), он реализует два интерфейса IPicture и Picture. С помощью них можно получить дополнительные свойства и методы объекта StdPicture.

Добавлено 01.02.14, 21:00

Цитата

получаю мусор в картинке. Значит, структура заголовка BMP в Image1(0).Picture отлична от структуры в Image1(1).Picture...

Да, у тебя создается картинка совместимая с контекстом, обычно это 32bpp, а исходная у тебя 24bpp. Если ты хочешь идентичные рисунки, то делай через CreateBitmap или CreateDIBSection и задавай нужное количество бит на канал.

[BlackSun]

не работает

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
 
Private Function CopyPicBMP(PicSource As StdPicture, WidthPic As Long, HeightPic As Long, BitsInColor As Long) As StdPicture
Dim hBMP As Long
    hBMP = CreateBitmap(WidthPic, HeightPic, 1, BitsInColor, PicSource.Handle)
    If hBMP <> 0 Then
        Set CopyPicBMP = Conv(hBMP)
    End If
End Function

[TheTrik]

Ну правильно, ты пустую картинку конвертируешь.

[BlackSun]

CreateBitmap принимает пустой массив под буфер или массив заполненных данных BMP?

Добавлено 02.02.14, 23:40
Заполнил внешний массив, должен быть белый цвет. Ничего.

Dim i As Long
For i = 1 To UBound(bArr)
 bArr(i) = 255
Next
    hBMP = CreateBitmap(WidthPic, HeightPic, 1, BitsInColor, bArr(1))