Solved

Resize and Save Picture

Posted on 2000-02-16
5
308 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
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 50 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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
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…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

758 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now