[RESOLVED] scaling StdPicture without picturebox

[maminej]

Hello everyone,

i passed the whole journey trying to make this function, without success

public function scalePic (inP as StdPicture, x as long, y as long ) as StdPicture

i need to rescale the StdPicture object without passing throug a picturebox control

All I can do now is :

just to be clear , I can do it that way :

1. Load image and generate a dc

    Dim DC As Long, picTemp As IPictureDisp
    DC = CreateCompatibleDC(0)
    If DC < 1 Then Exit Function
    Set picTemp = LoadPicture("c:\test.jpg")
    picWidth = ScaleX(picTemp.Width)
    picHeight = ScaleY(picTemp.Height)
    SelectObject DC, picTemp

2. Scaling the image into an imagebox

    StretchBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, picDc, 0, 0, picWidth, picHeight, vbSrcCopy
    Picture1.Refresh

3. Load the picture from the picturebox:

Dim p As StdPicture   
Set p = Picture1.Picture

Then i have a function to save the StdPicture object to jpg file

The problem here is that i dont want to use a picturebox in my application, and i can't make the StretchBlt API work without using a picturebox as dest handle

declaration:

Declare Function StretchBlt Lib "gdi32.dll" ( _
        ByVal hDC 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 nSrcWidth As Long, _
        ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

any idea

[LeandroA]

I made some tests, but I think that is the closest you can achieve.

Option Explicit
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As Any) As Long
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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
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

Const DI_MASK = &H1
Const DI_IMAGE = &H2


Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

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


Private Sub Command1_Click()
    Dim PicTemp As StdPicture
    
    'Set PicTemp = LoadPicture("d:\Mis documentos\Mis Accesorios para VB6\Mis Figuras\Iconos\nuevos_iconos_1\arrowleft_green16_h.ico")
    
    Set PicTemp = LoadPicture("c:\Image.bmp")

    If ResizePicture(PicTemp, 300, 300) Then
        Me.Picture = PicTemp
    End If
    
End Sub


Function ResizePicture(ByRef ThePicture As IPicture, ByVal NewWidth As Long, ByVal NewHeight As Long) As Boolean
    On Error GoTo Fail
    
    Dim Pic As PICTDESC, IID_IDispatch As GUID
    Dim hDCMemory As Long, DC As Long
    Dim PicDC As Long, OldhBmp As Long, PicW As Long, PicH As Long
    Dim hImage As Long, OldhImage As Long
    Dim hMask As Long, OldhMask As Long
    Dim hIcon As Long, II As ICONINFO
    
    'Scale in Pixels
    PicW = ScaleX(ThePicture.Width, vbHimetric, vbPixels)
    PicH = ScaleY(ThePicture.Height, vbHimetric, vbPixels)

    'Get Picture DC
    PicDC = CreateCompatibleDC(0)
    OldhBmp = SelectObject(PicDC, ThePicture.Handle)
    
    'create buffer DC
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(DC)
    
    CLSIDFromString StrPtr("{7BF80981-BF32-101A-8BBB-00AA00300CAB}"), IID_IDispatch
    
    If ThePicture.Type = vbPicTypeIcon Then
 
        hMask = CreateBitmap(NewWidth, NewHeight, 1, 1, ByVal 0&)
        OldhMask = SelectObject(hDCMemory, hMask)
        DrawIconEx hDCMemory, 0, 0, ThePicture.Handle, NewWidth, NewHeight, 0, 0, DI_MASK
        Call SelectObject(hDCMemory, OldhMask)
        
        hImage = CreateCompatibleBitmap(DC, NewWidth, NewHeight)
        OldhImage = SelectObject(hDCMemory, hImage)
        DrawIconEx hDCMemory, 0, 0, ThePicture.Handle, NewWidth, NewHeight, 0, 0, DI_IMAGE
        Call SelectObject(hDCMemory, OldhImage)
        
        II.hbmColor = hImage
        II.hbmMask = hMask
        
        hIcon = CreateIconIndirect(II)
        
        
        DeleteObject hImage
        DeleteObject hMask
        DeleteDC hDCMemory
        ReleaseDC 0&, DC
        
        With Pic
            .cbSizeofStruct = Len(Pic)
            .picType = ThePicture.Type
            .hImage = hIcon
        End With

        DeleteObject SelectObject(PicDC, OldhBmp)
        DeleteDC PicDC
        
        Set ThePicture = Nothing
        ResizePicture = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, ThePicture) = 0
        
    Else
    
        hImage = CreateCompatibleBitmap(DC, NewWidth, NewHeight)
        OldhImage = SelectObject(hDCMemory, hImage)
        SetStretchBltMode hDCMemory, vbPaletteModeHalftone
        StretchBlt hDCMemory, 0, 0, NewWidth, NewHeight, PicDC, 0, 0, PicW, PicH, vbSrcCopy
        Call SelectObject(hDCMemory, OldhImage)
        
        DeleteDC hDCMemory
        ReleaseDC 0&, DC
        DeleteObject SelectObject(PicDC, OldhBmp)
        DeleteDC PicDC
        
        With Pic
            .cbSizeofStruct = Len(Pic)
            .picType = ThePicture.Type
            .hImage = hImage
            .xExt = ThePicture.hPal
        End With
        
        ResizePicture = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, ThePicture) = 0
        
    End If
    
Fail:

End Function

[maminej]

Thank you very much my freind , I will give that a try

[MartinLiss]

If you download the code for my Picture/video Viewer you'll find a modFreeImage module. That module contains a lot of sophisticated routines for handling pictures. I don't know for sure if any of them do what you want but the FreeImage_RescaleEx procedure looks promising.

[LaVolpe]

Your method of scaling an image, is simply redrawing/resizing it to a new bitmap and creating a stdPicture from that bitmap. Without DLLs, Leandro's code or similar should do the trick.

However, you do not need to go thru all that just to draw the stdPicture to a DC using different scales. The .Render method of the stdPicture can do that for you. On this thread, post #16, I gave some sample code how that can be done.

Edited: And if you are going to draw into a VB form/control's DC and not using transparent GIFs, then VB's PaintPicture is all that you need.

[maminej]

Thanks everyone for your help, you are doing a great job

[MartinLiss]

maminej, did you see the private message I sent you?