• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 335
  • Last Modified:

Resize Image and save the resized version into a new file

I'm  now doing a project that requires me to convert an image
into a smaller size and save it into another file. In the other words, to create thumb nails for picture. Pls help!!!!!!!!!!
0
stchua
Asked:
stchua
  • 3
1 Solution
 
stchuaAuthor Commented:
Edited text of question.
0
 
HATCHETCommented:
stchua,

Do the following to make this work :

1) Create an empty project directory
2) Create a file called "Form1.txt" in the new directory
3) Go go into that file using NOTEPAD and paste the information below into it
4) Save the file
5) Rename the file to Form1.frm
6) Open the form in Visual Basic 5.0 or 6.0 (SP3 or better)
7) In VB, select the "Project" menu and choose "References"
8) Browse to "OLEPRO32.DLL" and add it to your project.
9) Run it

Lemme know if it works,

HATCHET

                      \/     Copy below this line     \/
____________________________________________________________

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   5265
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6120
   LinkTopic       =   "Form1"
   ScaleHeight     =   5265
   ScaleWidth      =   6120
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdSave
      Caption         =   "&Save"
      Default         =   -1  'True
      Height          =   435
      Left            =   4830
      TabIndex        =   6
      Top             =   2415
      Width           =   1170
   End
   Begin VB.CommandButton cmdClose
      Cancel          =   -1  'True
      Caption         =   "&Close"
      Height          =   435
      Left            =   4830
      TabIndex        =   5
      Top             =   4725
      Width           =   1170
   End
   Begin VB.PictureBox picStart
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   435
      Left            =   3780
      ScaleHeight     =   435
      ScaleWidth      =   435
      TabIndex        =   0
      Top             =   2415
      Visible         =   0   'False
      Width           =   435
   End
   Begin VB.FileListBox File1
      Height          =   2235
      Hidden          =   -1  'True
      Left            =   105
      Pattern         =   "*.BMP;*.GIF;*.JPG;*.JPEG;*.PCX;*.EMF;*.ICO"
      System          =   -1  'True
      TabIndex        =   4
      Top             =   2940
      Width           =   3480
   End
   Begin VB.DirListBox Dir1
      Height          =   2340
      Left            =   105
      TabIndex        =   3
      Top             =   525
      Width           =   3480
   End
   Begin VB.DriveListBox Drive1
      Height          =   315
      Left            =   105
      TabIndex        =   2
      Top             =   105
      Width           =   3480
   End
   Begin VB.PictureBox picMain
      Height          =   2220
      Left            =   3780
      ScaleHeight     =   2160
      ScaleWidth      =   2160
      TabIndex        =   1
      Top             =   105
      Width           =   2220
      Begin VB.Image imgMain
         Height          =   2115
         Left            =   0
         Stretch         =   -1  'True
         Top             =   0
         Width           =   2115
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

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
End Type

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

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 Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc _
  As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal _
  hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As _
  Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32.dll" (ByVal _
  hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, _
  lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32.dll" (lpLogPalette As _
  LOGPALETTE) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, _
  ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (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.dll" (ByVal hdc As Long) As _
  Long
Private Declare Function SelectPalette Lib "gdi32.dll" (ByVal hdc As Long, _
  ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32.dll" (ByVal hdc As Long) _
  As Long
Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) _
  As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, _
  ByVal hdc As Long) As Long

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) _
  As Picture
On Error Resume Next
 
  Dim r As Long
  Dim Pic As PicBmp
  Dim IPic As IPicture ' IPicture requires a reference to "Standard OLE Types."
  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

Private Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, _
  ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal _
  HeightSrc As Long) As Picture
On Error Resume Next
 
  Dim hDCMemory As Long
  Dim hBmp As Long
  Dim hBmpPrev As Long
  Dim r As Long
  Dim hDCSrc As Long
  Dim hPal As Long
  Dim hPalPrev As Long
  Dim RasterCapsScrn As Long
  Dim HasPaletteScrn As Long
  Dim PaletteSizeScrn As Long
 
  Dim LogPal As LOGPALETTE
 
  ' Depending on the value of Client get the proper device context
  If Client Then
    hDCSrc = GetDC(hWndSrc)       ' Get device context for client area
  Else
    hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire window
  End If
 
  ' Create a memory device context for the copy process
  hDCMemory = CreateCompatibleDC(hDCSrc)
  ' Create a bitmap and place it in the memory DC
  hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  hBmpPrev = SelectObject(hDCMemory, hBmp)
 
  ' Get screen properties.
  RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster capabilities
  HasPaletteScrn = RasterCapsScrn And RC_PALETTE       ' Palette support
  PaletteSizeScrn = GetDeviceCaps(hDCSrc, 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
    r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
    hPal = CreatePalette(LogPal)
    ' Select the new palette into the memory DC and realize it
    hPalPrev = SelectPalette(hDCMemory, hPal, 0)
    r = RealizePalette(hDCMemory)
  End If
 
  ' Copy the on-screen image into the memory DC
  r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, _
    vbSrcCopy)
 
  ' Remove the new copy of the  on-screen image
  hBmp = SelectObject(hDCMemory, hBmpPrev)
 
  ' If the screen has a palette get back the previously selected palette
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    hPal = SelectPalette(hDCMemory, hPalPrev, 0)
  End If
 
  ' Release the device context resources back to the system
  r = DeleteDC(hDCMemory)
  r = ReleaseDC(hWndSrc, hDCSrc)
 
  ' Call CreateBitmapPicture to create a picture object from the bitmap and
  ' palette handles. Then return the resulting picture object
  Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
   
End Function

Private Function LoadImage(FilePath As String) As Boolean
On Error GoTo ErrorTrap
 
  Dim x As Double
  Dim y As Double
  Dim Percent As Double
 
  imgMain.Visible = False
  picStart.Picture = LoadPicture(FilePath)
  DoEvents
 
  ' Get the dimentions of the original picture
  x = picStart.Width
  y = picStart.Height
 
  ' Check which dimention is greater & shrink image according to the ratio
  If x >= y Then
    If x > picMain.Width Then
      Percent = picMain.Width / x
      x = x * Percent
      y = y * Percent
    End If
  Else
    If y > picMain.Height Then
      Percent = picMain.Height / y
      x = x * Percent
      y = y * Percent
    End If
  End If
  imgMain.Width = x
  imgMain.Height = y
 
  ' Center the imgMain in picMain
  imgMain.Top = (picMain.Height \ 2) - (imgMain.Height \ 2)
  imgMain.Left = (picMain.Width \ 2) - (imgMain.Width \ 2)
 
  ' How copy over the picture to the correctly sized Image Control
  imgMain.Picture = picStart.Picture
  imgMain.Visible = True
 
  ' Clear the original
  picStart.Picture = LoadPicture()
 
  LoadImage = True
 
  Exit Function
 
ErrorTrap:
 
  If Err.Number = 0 Then
    Resume Next
  ElseIf Err.Number = 20 Then
    Resume Next
  Else
    MsgBox Err.Source & " caused the following error while sizing the " & _
      "picture:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & _
      Chr(13) & "Error Description = " & Err.Description, _
      vbOKOnly + vbExclamation, "  Error  -  " & Err.Description
    Err.Clear
    LoadImage = False
    'Exit Function
    Resume Next
  End If
 
End Function

Private Sub cmdClose_Click()
 
  Unload Me
 
End Sub

Private Sub cmdSave_Click()
On Error Resume Next
 
  Dim TwipX As Integer
  Dim TwipY As Integer
  Dim PicLeft As Integer
  Dim PicTop As Integer
  Dim PicWidth As Integer
  Dim PicHeight As Integer
  Dim FormLeft As Integer
  Dim FormTop As Integer
  Dim FilePath As String
 
  TwipX = Screen.TwipsPerPixelX
  TwipY = Screen.TwipsPerPixelY
 
  ' If there's a boarder, use the following to trim off the board
  PicLeft = (picMain.Left + (TwipX * 2)) / TwipX
  PicTop = (picMain.Top + (TwipY * 2)) / TwipY
  PicWidth = (picMain.Width - (TwipX * 4)) / TwipX
  PicHeight = (picMain.Height - (TwipY * 4)) / TwipY
 
  ' If there's no boarder, use the following instead
' PicLeft = picMain.Left / TwipX
' PicTop = picMain.Top / TwipY
' PicWidth = picMain.Width / TwipX
' PicHeight = picMain.Height / TwipY
 
  ' Prompt for save path
  FilePath = InputBox(Chr(13) & "Enter the full path to save file to:" & _
    Chr(13) & Chr(13) & "File is always saved as a Bitmap (.BMP) file", _
    "  Save As..", "C:\TEST.BMP")
 
  ' Check if user entered a value or not
  If FilePath <> "" Then
    ' If file exists, delete it
    If Dir(FilePath) <> "" Then
      Kill FilePath
    End If
    SavePicture CaptureWindow(Me.hwnd, True, PicLeft, PicTop, PicWidth, _
      PicHeight), FilePath
  End If
 
End Sub

Private Sub Dir1_Change()
 
  File1.Path = Dir1.Path
 
End Sub

Private Sub Drive1_Change()
 
  Dir1.Path = Drive1.Drive
 
End Sub

Private Sub File1_DblClick()
 
  If Right(File1.Path, 1) <> "\" Then
    LoadImage File1.Path & "\" & File1.filename
  Else
    LoadImage File1.Path & File1.filename
  End If
End Sub
0
 
HATCHETCommented:
stchua,

Feel free to UP the points on this one for the extra work I did on it if you like.       =]

HATCHET
0
 
Erick37Commented:
'Another way to save or view a thumbnail of a picture loaded into a picturebox:

Option Explicit
Const MAX_SIZE = 800 'Twips

Private Sub Command1_Click()
    Dim h As Long
    Dim w As Long
    Dim pic As StdPicture
    On Error GoTo THUMBERR
    'Get the picture loaded in picSrc
    'or load a picture using the "Open" dialog box
    Set pic = picSrc.Picture
    'Make sure we have a picture
    If pic = 0 Then Exit Sub
    'Convert the height and width to twips
    h = ScaleY(pic.Height, vbHimetric, vbTwips)
    w = ScaleX(pic.Width, vbHimetric, vbTwips)
    'Scale the destination picturebox to maintain
    'the same aspect ratio as original picture
    'but have max dimension of MAX_SIZE
    With picDst
    If w > h Then
        .Width = MAX_SIZE
        .Height = (h / w) * MAX_SIZE
    Else
        .Height = MAX_SIZE
        .Width = (w / h) * MAX_SIZE
    End If
    'Clear previous image and picture
    .Cls
    .Picture = LoadPicture("")
    'Scale the picture into the destination picbox
    .PaintPicture pic, 0, 0, .Width, .Height, 0, 0, w, h, vbSrcCopy
    'Convert the drawn image to the picture
    Set .Picture = .Image
    'Optionally save with "Save As" dialog box:
    '''SavePicture .Picture, "c:\thumb.bmp"
    End With
    'Clear the pic object
    Set pic = Nothing
    Exit Sub
THUMBERR:
    MsgBox Err.Description
    Err.Clear
End Sub

Private Sub Form_Load()
    '''picDst.Visible = False
    picDst.ScaleMode = 1 'Twip
    picDst.AutoRedraw = True
End Sub
0
 
HATCHETCommented:
Erick37,

Good suggestion there too!      =]

I tried it and it works well.
0

Featured Post

Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now