[RESOLVED] VBA: copy part of image

Hi,


For some more automatisation of some tasks at work I'm currently working on some code that should do the following:

I take a print screen of the active window and paste it in an image control "Image1" (not a picture control since these aren't available in VBA)? With a mouse_down, _move and _up event I can draw a 2nd image control (Image2) over the first one like a selection rectangle.
All this part is working. Now comes the part that I can't figure it out. When I push a command button "Cut" it should copy the part of Image1 where I drew the 2nd image over. Something like the "snipping tool" of windows vista.

I searched the web and already tried for some days to get it to work, but without succes.

I have read about paintpicture and what I can understand of it is that with paintpicture it should work and my issue should be solved. Unfortunately this isn't available with the Image control.

Can you help me?

note: My knowledge of vb and VBA is basic to moderate.

Thanks in advance..

No one?

I used the render method (somewhere I found omcode), but I can't get it to work. I tried the call .render method and the "with ... end with" method. Going step by step in the debugger, in both cases it passes the lines but Image2.picture is still empty

Declarations

Code:

---

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 Sub CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any)
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicArray As Any, RefIID As Any, ByVal OwnsHandle As Long, IPic As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Const StdPicGUID As String = "{00020400-0000-0000-C000-000000000046}"

---

The sub:

Code:

---

Sub Snipping
    Dim myDC As Long
    Dim OldBMP As Long
    Dim myBMP As Long
    Dim srcIPicture As IPicture
    Dim Result As IPicture
    Dim pd As PictDesc
    Dim IPic(15) As Byte

    myDC = CreateCompatibleDC(GetDC(0&))
    myBMP = CreateCompatibleBitmap(GetDC(0&), Image1.Width, Image1.Height)
    OldBMP = SelectObject(myDC, myBMP)

    Set srcIPicture = Image1.Picture

    With srcIPicture
          .Render myDC, 0, 0, (Image2.Width / 15), (Image2.Height/ 15),  _
                        SelXImg2 / 2540 * 1440, SelYImg2 / 2540 * 1440, _
                        (SelXImg2 + Image2.Width) / 2540 * 1440, -(SelYImg2 + Image2.Height) / 2540 * 1440, _
                        ByVal 0&
    End With

'SelXImg2 and SelYImg2are are the points where I started the selection on Image1.


    pd.cbSizeofStruct = Len(pd)
    pd.picType = 1
    pd.hImage = myBMP



    CLSIDFromString StrPtr(StdPicGUID), IPic(0)
    OleCreatePictureIndirect pd, IPic(0), True, Result

    Set Image2.Picture = Result

    DeleteObject SelectObject(myDC, OldBMP)
    DeleteDC myDC
   
End sub

---

As in vba the scaleX and scaleY aren't available I tried to convert the units myself with some"most common" values.

Can someone help me?

Seems it should work.
Only OleCreatePictureIndirect wants its fourth paramater to be of type IPicture.
Your Result variable is of type Image, which is a control. So maybe this function failed.
You could check if it fails like:

Code:

---

dim res as long
res = OleCreatePictureIndirect(pd, IPic(0), True, Result)
'instead of
'OleCreatePictureIndirect pd, IPic(0), True, Result

---

If res is zero the function was successful. A nonzero return value indicates an error.
I'd try
Dim Result as IPicture
instead of an Image.

WoF,

thanks for your reply. I tried the line you suggested and indeed the res = 0. Meaning the function is succesful. However it still does not work my "Image2" is still empty and not filled with the part of Image1 I have "selected".
Any more suggestions please?

Have you tried Image2.Refresh?

I would like to try but the Image2.refresh isn't available nor does the .repaint.

Since the code I got is somewhere from the net I'm trying to understand what it exactly does. I don't know why we need the line of the "OldBMP = Selectobject ...." because when I delete this line my Image2 becomes a whole black box.
What I understand of the code so far is, first it takes a memory bitmap of image1.
Then with the .render it takes a part of image1 (= to the dimensions and start point of Image2) .
1) What I don't understand is, where is the render stored. It should be somewhere telling that x is the rendered part of image1.

Then the pd.... is creating the parameters for the new picture (PictDesc), the clsIDfromString converts the GUID string into the original Class ID (a picture, I think).
The olecreatePicture is actually creating the picture taking into account the picture parameters (pictdesc), the converted GUID string and put it into "result".

2) What I don't understand is, where is the link between the rendered picture and the new created picture?

3) the StdGuid (a private const declaration) is this correct?

Thanks for all your help so far.

First a blank Bitmap with the same Size as Image1 is created and assigned to myDC

The Image1 redering has myDC as target -> store the rendered Picture in myDC (myBMP)

Then the BMP is converted to the iPicture Format

I have a similar function, but the GUID is diffrent

Code:

---

Function BitmapToPicture(hBitmap as Long)
  Dim IPic As IPicture, picdes As PICTDESC, iidIPicture As GUID
  ' Fill picture description
  picdes.cbSizeofstruct = Len(picdes)
  picdes.picType = vbPicTypeBitmap '// = 1
  picdes.hGDIObj = hBitmap
  ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  iidIPicture.Data1 = &H7BF80980
  iidIPicture.Data2 = &HBF32
  iidIPicture.Data3 = &H101A
  iidIPicture.Data4(0) = &H8B
  iidIPicture.Data4(1) = &HBB
  iidIPicture.Data4(2) = &H0
  iidIPicture.Data4(3) = &HAA
  iidIPicture.Data4(4) = &H0
  iidIPicture.Data4(5) = &H30
  iidIPicture.Data4(6) = &HC
  iidIPicture.Data4(7) = &HAB
  ' Create picture from icon handle
  OleCreatePictureIndirect picdes, iidIPicture, True, IPic
  ' Result will be valid Picture or Nothing--either way set it
  Set BitmapToPicture = IPic

---

Ok thanks alot for your support. Now I understand.
I think I might know why it is not working. Could it be due to an incorrect GUID string?

Code:

---

Private Const StdPicGUID As String = "{00020400-0000-0000-C000-000000000046}"

---

I saw that the one I use is different from the one you use (Dagnarus).
Can you help me on how do I determine which GUID to use?

Thanks in advance.

I found some code to get the GUID from the references I use in this project.
I tried every GUID from the list. None is giving me the result in Image2.Picture.
Only the GUID posted in my code above is giving a 0 for "res" as WoF described. Also the GUID from Dagnarus code is giving me a 0 for "res". Meaning there is no error for the "OleCreatePictureIndirect" line with both GUID's however none is giving me the partial picture of image1 into Image2.

Can some CodeGuru's helpme please?

Ok I tried some more and when I add the following code after the line
"set Image2.picture = Result"

Code:

---

Dim FileName as string
Filename = "C:\test.bmp"
SavePicture Result, FileName

---

and check if it worked. Well there is a bmp at C:\ called "test.bmp". When I open this image in any program it is just a black box with the correct size. The size of the selection box (Image2).
It only does not contain the part of the picture of Image1.
Does anyone know why it is a black box?

And the set Image2.picture = result has no result. Meaning the Image2 doesn't even show a black box.

All help is appreciated

It seems to work, only some wrong X ad Y coordination which I can't solve (all the src ... part seems to be modified).

Code:

---

    Set srcIPicture = Image1.Picture

    tgtX = 0
    tgtY = 0
    tgtWidth = Image2.Width
    tgtHeight = Image2.Height
    srcX = SelXImg2 / 1440 * 2540 * TwipsPerPixelX
    srcY = SelYImg2 / 1440 * 2540 * TwipsPerPixelY
    srcWidth = (SelXImg2 + Image2.Width) / 1440 * 2540 * TwipsPerPixelX
    srcHeight = -(SelYImg2 + Image2.Height) / 1440 * 2540 * TwipsPerPixelY

    With srcIPicture
        .Render myDC, tgtX, tgtY, tgtWidth, tgtHeight, srcX, srcY, srcWidth, srcHeight, ByVal 0&
    End With

'SelXImg2 and SelYImg2 are the points where I started the selection of Image2 on Image1.

---

Just a question, in the render function the srcX and srcY are those seen of Image1 or of the form? Because the Image2.left and .top is different from the X and Y coordinates selected on Image1.

The render part is working, finaly. I had to put a correction factor to it. Why I don't know yet.
So my render function is looking like this:

Code:

---

    Dim tgtX As Long
    Dim tgtY As Long
    Dim tgtWidth As Long
    Dim tgtHeight As Long
    Dim srcX As Long
    Dim srcY As Long
    Dim srcHeight As Long
    Dim srcWidth As Long
   
    tgtX = 0
    tgtY = 0
    tgtWidth = Image2.Width
    tgtHeight = Image2.Height
    srcX = SelXImg2 / 1440 * 2540 * TwipsPerPixelX * 1.333
    srcY = Image1.Picture.Height - SelYImg2 / 1440 * 2540 * TwipsPerPixelY * 1.333
    srcWidth = (Image2.Width) / 1440 * 2540 * TwipsPerPixelX * 1.333
    srcHeight = -(Image2.Height) / 1440 * 2540 * TwipsPerPixelY * 1.333 

    With srcIPicture
        .Render myDC, tgtX, tgtY, tgtWidth, tgtHeight, srcX, srcY, srcWidth, srcHeight, ByVal 0&
    End With

---

When I save the rendered picture to a test.bmp and when I open it afterwards, it shows the renderd picture. Code is as follows:

Code:

---

    pd.cbSizeofStruct = Len(pd)
    pd.picType = 1
    pd.hImage = myBMP

    Dim res As Long

    CLSIDFromString StrPtr(StdPicGUID), IPics(0)
    'If res = 0 then function was succesful
    res = OleCreatePictureIndirect(pd, IPics(0), True, Result)

    Dim FileName as string
    FileName = "C:\....."  'entered path and full filename as test.bmp

    SavePicture Result, FileName

---

But when I try to set this result to another image box (Image3) it does not work.
I tried this:

Code:

---

    pd.cbSizeofStruct = Len(pd)
    pd.picType = 1
    pd.hImage = myBMP

    Dim res As Long

    CLSIDFromString StrPtr(StdPicGUID), IPics(0)
    'If res = 0 then function was succesful
    res = OleCreatePictureIndirect(pd, IPics(0), True, Result)

   
    Set Image3.Picture = Result

---

The result is an IPicture.

Can ayone advise me please?

Ah bless you. I must have searched long and hard throughout what seemed to be the entire internet only to find this topic which has exactly the implementation I was looking for.

I did note the same problem -- I was able to call SaveFile and the resulting image looked fine, but setting the .Picture property of an Image had no effect.

I did manage to find a resolution by plugging away at my code... I see the first edition of the code had the SelectObject call, and tried to release the objects -- I'm not sure if this was ommitted in later versions, or left out for brevity ..... if the former, this might do it:

Code:

---

  myDC = CreateCompatibleDC(GetDC(0&))
  myBMP = CreateCompatibleBitmap(GetDC(0&), newWidth, newHeight)
  OldBMP = SelectObject(myDC, myBMP)
 ... etc.....
  DeleteObject OldBMP
  DeleteDC myDC

---

That got it working for me. Also, this page (http://www.vbforums.com/showthread.php?t=610000) has a pretty good description of the Render sub... I didn't use any of the code, but it does detail destination inputs are in pixels, while source parameters are in himetrics. Getting the source parameters can be done like so:

Code:

---

dim iPic as IPicture
set iPic = image1.picture
debug.print iPic.Height & "x" & iPic.Width

---

Great! Please pull down the thread tools at the top of the thread, and MARK IT AS RESOLVED!