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: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
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…
Suggested Courses

862 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