Resize and Save Picture

I have loaded picture in picture box, how I can resize this
picture or stretch it to any size and save it to BMP file.

P.S. I don't want to use any of DLL's or OCX's except
windows based dll's.

Thank you.
Who is Participating?
Erick37Connect With a Mentor Commented:
No-API method

Private Sub Form_Load()
    'pb is a picturebox, index 0
    On Error Resume Next
    pb(0).Picture = LoadPicture("c:\background.gif")
    Debug.Print ScaleAndSave(pb(0).Picture, 50, "c:\test.bmp")
End Sub

Private Function ScaleAndSave(pic As StdPicture, pScale As Single, sFilename As String) As Boolean
    On Error GoTo ERRPIC
    Dim dx As Long, dy As Long
    If pScale <= 0 Then
        pScale = 100
    End If
    Load pb(1)
    dx = ScaleX(pic.Width, vbHimetric, Me.ScaleMode)
    dy = ScaleY(pic.Height, vbHimetric, Me.ScaleMode)
    With pb(1)
    .BorderStyle = 0 'none
    .Width = dx * (pScale / 100)
    .Height = dy * (pScale / 100)
    .AutoRedraw = True
    .PaintPicture pb(0).Picture, 0, 0, .Width, .Height, 0, 0, dx, dy, vbSrcCopy
    .Picture = .Image
    SavePicture .Picture, sFilename
    .Picture = LoadPicture("")
    End With
    Unload pb(1)
    ScaleAndSave = True
    Exit Function
    MsgBox Err.Description
    ScaleAndSave = False
End Function
Easy way to save is with built in VB function SavePicture, use:

SavePicture PictureBox, FileName

To stretch use BitBlt (API call) to another picture box and then same as above.
The code below is not quite what you're looking for, but you should be able to modify it to suit your needs.

CreateBitmapPicture returns a Picture object which you can then use in a SavePicture call

Check out the StretchBLT API for your stretching requirement

Option Explicit
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect _
    Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
End Type
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" ( _
                         ByVal hWnd As Long) 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 Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
                         ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" ( _
    ByVal hDC As Long, ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _
    As Long
Private Declare Function CreatePalette Lib "gdi32" ( _
                         lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" ( _
                         ByVal hDC As Long, ByVal hPalette As Long, _
                         ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" ( _
                         ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
                ByVal hDCDest As Long, ByVal XDest As Long, _
                ByVal YDest As Long, ByVal nWidth As Long, _
                ByVal nHeight As Long, ByVal hDCSrc As Long, _
                ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
                As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
                ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateDC Lib "gdi32" _
                Alias "CreateDCA" (ByVal lpDriverName As String, _
                                   ByVal lpDeviceName As String, _
                                   ByVal lpOutput As String, _
                                   ByVal lpInitData As Long) As Long
Private Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
' CreateBitmapPicture
'    - Creates a bitmap type Picture object from a bitmap and
'      palette.
' hBmp
'    - Handle to a bitmap.
' hPal
'    - Handle to a Palette.
'    - Can be null if the bitmap doesn't use a palette.
' Returns
'    - Returns a Picture object containing the bitmap.
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
                                    ByVal hPal As Long) As Picture

Dim r As Long
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim IPic As IPicture
Dim IID_IDispatch As GUID

' Fill in with IDispatch Interface ID.
With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
End With

' Fill Pic with necessary parts.
With Pic
    .Size = Len(Pic)          ' Length of structure.
    .Type = vbPicTypeBitmap   ' Type of Picture (bitmap).
    .hBmp = hBmp              ' Handle to bitmap.
    .hPal = hPal              ' Handle to palette (may be null).
End With

' Create Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

' Return the new Picture object.
Set CreateBitmapPicture = IPic

End Function

Public Function GetScreenPicture() As Picture
Dim hEndResultDCSrc As Long
Dim hEndResultDC As Long
Dim hEndResultBmp As Long
Dim hEndResultBmpPrev As Long
Dim hEndResultPal As Long
Dim hEndResultPalPrev As Long
Dim lngReturnCode As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long

'Get device context for client area.
hEndResultDCSrc = GetDC(GetDesktopWindow)

'Create a memory device context for the image.
hEndResultDC = CreateCompatibleDC(hEndResultDCSrc)

' Create a bitmap and place it in the memory DC.
hEndResultBmp = CreateCompatibleBitmap(hEndResultDCSrc, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)

'I don't know why this is done...
hEndResultBmpPrev = SelectObject(hEndResultDC, hEndResultBmp)

' Get screen properties.
RasterCapsScrn = GetDeviceCaps(hEndResultDCSrc, RASTERCAPS) ' Raster
                                                   ' capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE       ' Palette
                                                     ' support.
PaletteSizeScrn = GetDeviceCaps(hEndResultDCSrc, SIZEPALETTE) ' Size of
                                                     ' palette.

' If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    ' Create a copy of the system palette.
    LogPal.palVersion = &H300
    LogPal.palNumEntries = 256
    lngReturnCode = GetSystemPaletteEntries(hEndResultDCSrc, _
                                            0, _
                                            256, _
    hEndResultPal = CreatePalette(LogPal)
    ' Select the new palette into the memory DC and realize it.
    hEndResultPalPrev = SelectPalette(hEndResultDC, hEndResultPal, 0)
    lngReturnCode = RealizePalette(hEndResultDC)
End If

BitBlt hEndResultDC, _
       0, _
       0, _
       Screen.Width / Screen.TwipsPerPixelX, _
       Screen.Height / Screen.TwipsPerPixelY, _
       hEndResultDCSrc, _
       0, _
       0, _

' Remove the new copies of the  on-screen image. <-why is this done?
hEndResultBmp = SelectObject(hEndResultDC, hEndResultBmpPrev)

' If the screen has a palette get back the palette that was
' selected in previously.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    hEndResultPal = SelectPalette(hEndResultDC, hEndResultPalPrev, 0)
End If

' Release the device context resources back to the system.
lngReturnCode = DeleteDC(hEndResultDC)
lngReturnCode = ReleaseDC(GetDesktopWindow, hEndResultDCSrc)


' Call CreateBitmapPicture to create a picture object from the
' bitmap and palette handles. Then return the resulting picture
' object.
Set GetScreenPicture = CreateBitmapPicture(hEndResultBmp, hEndResultPal)

End Function

1 - Get your original Picture object
2 - Use its Handle and StretchBLT in a modification of GetScreenPicture
3 - Use CreateBitmapPicture to create a new Picture object
4 - SavePicture.
RuslanMAuthor Commented:
I thing that Erick37's method is more fast and easy, so I desided to accept it as an anwser. Thank you caraf_g for your comment.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.