Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Resize and Save Picture

Posted on 2000-02-16
5
Medium Priority
?
357 Views
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.
0
Comment
Question by:RuslanM
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
5 Comments
 
LVL 1

Expert Comment

by:macu
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.
0
 
LVL 10

Expert Comment

by:caraf_g
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
'
Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Private Type LOGPALETTE
    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
Dim LogPal As LOGPALETTE

'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, _
                                            LogPal.palPalEntry(0))
    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, _
       SRCCOPY


' 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
0
 
LVL 10

Expert Comment

by:caraf_g
ID: 2526776
Basically

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

Accepted Solution

by:
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
ERRPIC:
    MsgBox Err.Description
    ScaleAndSave = False
End Function
0
 

Author Comment

by:RuslanM
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.
0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

Question has a verified solution.

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

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
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

636 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