Hi all,

with the help of the web, I figured out a way to get the pixels in a
StdPicture object, basically using GetDIBits. This works fine with
StdPicture type 1 (Bitmap)

However, it does not work at all with a StdPicture of type 4 (Enhanced
Metafile). Any suggestions how I might be able to get the pixels in a
bitmap-like-format from such a StdPicture object? I have already tried
rendering it to a memory DC, but the Render method won't do it (Error).

<asperama***@gmail.com> schrieb im Newsbeitrag
A StdPicture which contains (after loading from File) such
an (Enhanced)Metafile-Picture will be rendered dynamically
already against "Pixels", if you host this StdPicture in an
appropriate Container - e.g.a VB-PictureBox-Control
(then rendered against its hDC).

So, the GetPixel-Call against a PictureBox.hDC should
already succeed (after the rendering of the EMF-StdPicture-
Content took place in your GUI).
If you don't want to work with the GetPixel-API, because
that is too slow for your purposes, then yes - you should
render the EMF-content not against a Screen-hDC, but
against a Memory-DC instead.
This can be achieved either over plain API - or in case
of a VB-PictureBox, if you switch the PictureBox to
AutoRedraw=True - then you should be able to
retrieve the entire Pixel-Content of that PictureBox
with one Call (working against the .Image-Property
of that AutoRedraw-PictureBox).

Maybe just show your code you currently have.

Olaf

Alright, here's the code I have. It works just fine with a BMP, but
not with an EMF:

===

Private Sub GetPixelsFromPicture(ByRef aPic As StdPicture, _
                                 ByRef bi As BITMAPINFO, _
                                 ByRef bBuffer() As Byte)
   Dim hDCTemp As Long
   Dim hBmp As Long
   Dim hObjectPrev As Long
   Dim lngRc As Long

   With bi.bmiHeader
      .biBitCount = 32
      .biCompression = BI_RGB
      .biPlanes = 1
      .biSize = LenB(bi.bmiHeader)
      .biWidth = CLng(Me.ScaleX(aPic.Width, vbHimetric, vbPixels))
      .biHeight = CLng(Me.ScaleY(aPic.Height, vbHimetric, vbPixels))

      ReDim bBuffer(1 To (.biWidth * .biHeight * 4) + 1)
   End With

   hDCTemp = CreateCompatibleDC(0)
   hObjectPrev = SelectObject(hDCTemp, aPic.Handle)
   lngRc = GetDIBits(hDCTemp, aPic.Handle, 0, bi.bmiHeader.biHeight,
bBuffer(1), bi, DIB_RGB_COLORS)

   hBmp = SelectObject(hDCTemp, hObjectPrev)

   Call DeleteDC(hDCTemp)
End Sub

===

I can see the problem of this approach: Directly selecting an EMF into
a screen (and therefore bitmap)-compatible DC fails. So I've written
another version:

===

Private Sub GetPixelsFromEMF(ByRef aPic As StdPicture, _
                             ByRef bi As BITMAPINFO, _
                             ByRef bBuffer() As Byte)
   Dim hDCTemp As Long
   Dim hBmp As Long
   Dim hObjectPrev As Long
   Dim lngRc As Long

   With bi.bmiHeader
      .biBitCount = 32
      .biCompression = BI_RGB
      .biPlanes = 1
      .biSize = LenB(bi.bmiHeader)
      .biWidth = CLng(Me.ScaleX(aPic.Width, vbHimetric, vbPixels))
      .biHeight = CLng(Me.ScaleY(aPic.Height, vbHimetric, vbPixels))

      ReDim bBuffer(1 To (.biWidth * .biHeight * 4) + 1)
   End With

   hDCTemp = CreateCompatibleDC(0)
   hBmp = CreateCompatibleBitmap(hDCTemp, bi.bmiHeader.biWidth,
bi.bmiHeader.biHeight)
   hObjectPrev = SelectObject(hDCTemp, hBmp)

   Call aPic.Render(hDCTemp, 0, 0, CLng(bi.bmiHeader.biWidth), CLng
(bi.bmiHeader.biHeight), _
                    0, 0, aPic.Width, aPic.Height, ByVal 0&)
   lngRc = GetDIBits(hDCTemp, hBmp, 0, bi.bmiHeader.biHeight, bBuffer
(1), bi, DIB_RGB_COLORS)
   hBmp = SelectObject(hDCTemp, hObjectPrev)

   Call DeleteObject(hBmp)
   Call DeleteDC(hDCTemp)
End Sub

===

This version fails at the Render method, with "Invalid Procedure call
or argument"

What do I do wrong?

<asperama***@gmail.com> schrieb im Newsbeitrag
Ah, Ok.
I see now, that you want to get a Pixel-Array back.

Don't have that much time, to analyze your code in deep
(and why it does not work against Metafiles), but from a
short look this line is for example not correct (regarding
the allocation of your ByteArray, which is one byte too large).

But that's not the cause for the failing EMF-rendering.
I see, that you use the render-method of the StdPicture-
Object, but I'm not sure, if it is used correctly in your
example - and if it is capable, to render EMF from the
internal StdPic-Handle directly.

So I've put a small Demo together, which works and uses
PlayEnhMetafile against a DIBSection directly, so that
no surprises with the StdPicture.Render-methods are
possible.

'***Into a form, adjust the Filenames and click the form

Option Explicit

Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC&, _
  ByVal hBM&, ByVal nStartSL&, ByVal nNumSL&, lpBits As Any, _
  lpBI As Any, ByVal wUsage&)
Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hDC&)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hDC&)
Private Declare Function StretchDIBits& Lib "gdi32" (ByVal hDC&, _
  ByVal x&, ByVal y&, ByVal dX&, ByVal dY&, ByVal SrcX&, ByVal SrcY&, _
  ByVal Srcdx&, ByVal Srcdy&, lpBits As Any, lpBitsInfo As Any, ByVal _
  wUsage&, ByVal dwRop&)
Private Declare Function CreateDIBSection& Lib "gdi32" (ByVal hDC&, _
  pBitmapInfo As Any, ByVal un&, ppBits&, ByVal Hdl&, ByVal dw&)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hDC&, _
  ByVal hObject&)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
Private Declare Function PlayEnhMetaFile& Lib "gdi32" (ByVal hDC&, _
  ByVal hemf&, lpRect As RECT)
Private Declare Sub RtlMoveMemory Lib "kernel32" (Dest As Any, _
  Src As Any, ByVal BCount&)

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 RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type BGRQuad
  B As Byte
  G As Byte
  R As Byte
  A As Byte
End Type

Private Arr() As BGRQuad

Private Sub Form_Click()
Dim x&, y&
  'GetArrFromHdl Arr, LoadPicture("c:\test.bmp")

  'the above works for StdPictures with Pixel-Content - but
  'EMF is a vector-format, which needs rendering first on an
  'InMemory-Bitmap (ensured over PlayEnhMetafile in GetArrFromEMFHdl)
  GetArrFromEMFHdl Arr, LoadPicture("c:\test.emf"), 200, 100

  'enhance the Blue-component in our Pxl-Arr, just to change something
  For x = 0 To UBound(Arr, 1)
    For y = 0 To UBound(Arr, 2)
      Arr(x, y).B = 255
    Next y
  Next x

  DrawArr Arr, hDC 'finally draw the Array-Content
End Sub

Private Sub GetArrFromEMFHdl(Pxl() As BGRQuad, ByVal Hdl As Long, _
                             ByVal dX As Long, ByVal dY As Long)
  If dX <= 0 Or dY <= 0 Then Exit Sub
Dim BI As BITMAPINFOHEADER, hDC As Long
Dim OldBM As Long, pBits As Long, R As RECT

  BI.biSize = 40
  BI.biWidth = dX
  BI.biHeight = -dY
  BI.biPlanes = 1
  BI.biBitCount = 32

  hDC = CreateCompatibleDC(0)
  OldBM = SelectObject(hDC, CreateDIBSection(0, BI, 0, pBits, 0, 0))
  If pBits <> 0 And hDC <> 0 Then
    R.Right = dX
    R.Bottom = dY
    PlayEnhMetaFile hDC, Hdl, R
    ReDim Pxl(0 To dX - 1, 0 To dY - 1)
    RtlMoveMemory Pxl(0, 0), ByVal pBits, 4 * dX * dY
  End If

  If OldBM Then DeleteObject SelectObject(hDC, OldBM)
  If hDC Then DeleteDC hDC
End Sub

Private Sub GetArrFromHdl(Pxl() As BGRQuad, ByVal Hdl As Long)
Dim BI As BITMAPINFOHEADER, hDC As Long
  hDC = CreateCompatibleDC(0)

  BI.biSize = 40
  GetDIBits hDC, Hdl, 0, 0, ByVal 0&, BI, 0
  If BI.biWidth = 0 Or BI.biHeight = 0 Then
    If hDC Then DeleteDC hDC
    Exit Sub
  End If

  BI.biPlanes = 1
  BI.biBitCount = 32
  BI.biCompression = 0
  ReDim Pxl(0 To BI.biWidth - 1, 0 To BI.biHeight - 1)
  BI.biHeight = -BI.biHeight
  GetDIBits hDC, Hdl, 0, -BI.biHeight, Pxl(0, 0), BI, 0

  If hDC Then DeleteDC hDC
End Sub

Private Sub DrawArr(Pxl() As BGRQuad, hDC As Long)
Dim BI As BITMAPINFOHEADER, W As Long, H As Long
  On Error Resume Next
    W = UBound(Pxl, 1) + 1: H = UBound(Pxl, 2) + 1
  If Err Then Err.Clear
  If W = 0 Or H = 0 Then Exit Sub

  BI.biSize = 40
  BI.biWidth = W
  BI.biHeight = -H
  BI.biPlanes = 1
  BI.biBitCount = 32

  StretchDIBits hDC, 0, 0, W, H, 0, 0, W, H, Pxl(0, 0), BI, 0, vbSrcCopy
End Sub


Olaf

Thanks a lot! The PlayEnhMetafile, and it's use combined with a DIB
section was the missing link!

I've now written my own function that takes a StdPicture of type EMF,
and saves it to disc as a BMP file. The actual saving code is based on
this page: http://www.vb-helper.com/howto_memory_bitmap_save.html (but
modified by me)

It is able to convert and save even very large EMFs in reasonable time
(given it's still a quick'n dirty implementation)

===

Private Sub SaveEMFAsBMP(ByRef aPic As StdPicture, _
                         ByVal strFilename As String)
   Dim bf As BITMAPFILEHEADER
   Dim fnum As Long
   Dim bBuffer() As Byte
   Dim hDCTemp As Long
   Dim bi As BITMAPINFO
   Dim hBmp As Long
   Dim hBmpOld As Long
   Dim pBits As Long
   Dim r As RECT
   Dim lngTotalSize As Long
   Dim pCur As Long
   Dim lngBlockLen As Long

   With bi.bmiHeader
      .biBitCount = 32
      .biCompression = BI_RGB
      .biPlanes = 1
      .biSize = LenB(bi.bmiHeader)
      .biWidth = CLng(Me.ScaleX(aPic.Width, vbHimetric, vbPixels))
      .biHeight = -CLng(Me.ScaleY(aPic.Height, vbHimetric, vbPixels))
   End With

   With bf
     .bfType = &H4D42   ' "BM"
     .bfOffBits = Len(bf) + _
           Len(bi.bmiHeader)
     .bfSize = .bfOffBits + _
           bi.bmiHeader.biSizeImage
   End With


   ' Open the output bitmap file.
   fnum = FreeFile
   Open strFilename For Binary As fnum

   ' Write the BITMAPFILEHEADER.
   Put #fnum, , bf

   ' Write the BITMAPINFOHEADER.
   ' (Note that
   ' memory_bitmap.bitmap_info.bmiHeader.biHeight
   ' must be positive for this.)
   Put #fnum, , bi

   hDCTemp = CreateCompatibleDC(0)
   hBmp = CreateDIBSection(0, bi, DIB_RGB_COLORS, pBits, 0, 0)
   hBmpOld = SelectObject(hDCTemp, hBmp)

   With r
      .Left = 0
      .Top = 0
      .Right = bi.bmiHeader.biWidth
      .Bottom = -bi.bmiHeader.biHeight
   End With

   Call PlayEnhMetaFile(hDCTemp, aPic.Handle, r)

   lngTotalSize = Abs(bi.bmiHeader.biWidth * bi.bmiHeader.biHeight *
4)

   lngBlockLen = 10000
   ReDim bBuffer(1 To lngBlockLen)
   pCur = 0
   Do While (pCur < lngTotalSize)
      If ((lngTotalSize - pCur) < lngBlockLen) Then
         lngBlockLen = (lngTotalSize - pCur)
         ReDim bBuffer(1 To lngBlockLen)
      End If

      Call CopyMemory(VarPtr(bBuffer(1)), pBits + pCur, lngBlockLen)

      ' Write the DIB bits.
      Put #fnum, , bBuffer
      pCur = pCur + UBound(bBuffer)
   Loop


   Call SelectObject(hDCTemp, hBmpOld)
   Call DeleteObject(hBmp)
   Call DeleteDC(hDCTemp)

   ' Close the file.
   Close fnum
End Sub

===

Thanks again!

Help with a bit of maths
GetObject with VB6 ActiveX exe
Anyone know of a good Help Authorizing Tool
Create Icon File From Resource
Prohibit Paste
Changing a property on a control
Vista and AutoRedraw
Phone system integrated in vb app
Sort UDT vs Database
General Question on Deployment Stratagies