Resize and Save Picture

Posted on 2000-02-16
Medium Priority
Last Modified: 2008-03-10
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.
Question by:RuslanM

Expert Comment

ID: 2526751
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.
LVL 10

Expert Comment

ID: 2526769
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
LVL 10

Expert Comment

ID: 2526776

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.
LVL 32

Accepted Solution

Erick37 earned 200 total points
ID: 2528626
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

Author Comment

ID: 2566315
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.

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

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.

Join & Write a Comment

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

587 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question