How to use stretchblt gdi32.dll API function in vba 1

[090110]

Hi,

I am trying to program excel to create a smaller version of a picture displayed on an microsoft 2.0 image control in a userform that I have created and save it as a file.

I have been looking around for a while and it seems that the stretchblt function from the gdi32.dll is probably best suited. The software I am creating will be used by a number of users and I do not want to install additional files on their computer so hence I am trying to use functions that are present in most windows operating systems.

I have searched the web and cannot find the code to do it. Can someone please help me as I am out of my depth with this problem.

Thanks.

 

[strongm]

The image control already wraps the StretchBlt API; the Picture property has a Render method.

 

[090110]

Thank you strongm,

I had a look at the object browser but I do not know what it all means and where to get all information from.

Sub Render(hdc As Long, x As Long, y As Long, cx As Long, cy As Long, xSrc As OLE_XPOS_HIMETRIC, ySrc As OLE_YPOS_HIMETRIC, cxSrc As OLE_XSIZE_HIMETRIC, cySrc As OLE_YSIZE_HIMETRIC, prcWBounds As Any)

Does anyone have an implementation of the above code.

Thanks.

 

[strongm]

Okey dokey ...

[blue]Private Function ResizeAndSave(ByVal SourceImage As Image, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal FileName As String) As Boolean
    Dim myDC As Long
    Dim OldBMP As Long
    Dim myBMP As Long
    Dim srcIPicture As stdole.IPicture
    Dim Result As stdole.IPicture
    
    Dim pd As PictDesc
    Dim IPic(15) As Byte
    
    myDC = CreateCompatibleDC(GetDC(0&))
    myBMP = CreateCompatibleBitmap(GetDC(0&), NewWidth, NewHeight)
    OldBMP = SelectObject(myDC, myBMP)

    Set srcIPicture = SourceImage.Picture ' get different interface to the picture object
    With srcIPicture
        .Render myDC, 0, 0, NewWidth, NewHeight, 0, .height, .Width, -.height, ByVal 0&
    End With
    
    ' We now have a bitmap in myDC with the resized picture, whcih we want to be able to save
    ' so we can leverage the SavePicture method if we can turn that into a StdPic
    
    pd.cbSizeofStruct = Len(pd)
    pd.picType = 1
    pd.hImage = myBMP
    
    CLSIDFromString StrPtr(StdPicGUID), IPic(0)
    OleCreatePictureIndirect pd, IPic(0), True, Result
   
    SavePicture Result, FileName

    ResizeAndSave = Result.Handle <> 0
End Function[/blue]

 

[strongm]

Sorry - forgot the declarations you'll need:

[blue]Option Explicit

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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicArray As Any, RefIID As Any, ByVal OwnsHandle As Long, IPic As Any) 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}"

Private Function ResizeAndSave(ByVal SourceImage As Image, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal FileName As String) As Boolean
    Dim myDC As Long
    Dim OldBMP As Long
    Dim myBMP As Long
    Dim srcIPicture As stdole.IPicture
    Dim Result As stdole.IPicture
    
    Dim pd As PictDesc
    Dim IPic(15) As Byte
    
    myDC = CreateCompatibleDC(GetDC(0&))
    myBMP = CreateCompatibleBitmap(GetDC(0&), NewWidth, NewHeight)
    OldBMP = SelectObject(myDC, myBMP)

    Set srcIPicture = SourceImage.Picture [green]' get different interface to the picture object[/green]
    With srcIPicture
        .Render myDC, 0, 0, NewWidth, NewHeight, 0, .height, .Width, -.height, ByVal 0&
    End With
    
    [green]' We now have a bitmap in myDC with the resized picture, whcih we want to be able to save
    ' so we can leverage the SavePicture method if we can turn that into a StdPic[/green]
    
    pd.cbSizeofStruct = Len(pd)
    pd.picType = 1
    pd.hImage = myBMP
    
    CLSIDFromString StrPtr(StdPicGUID), IPic(0)
    OleCreatePictureIndirect pd, IPic(0), True, Result
   
    SavePicture Result, FileName

    ResizeAndSave = Result.Handle <> 0
End Function[/blue]

 

[090110]

Strongm,

You are a genius!

You have saved me countless hours of aimlessly searching the web.

Thanks.