ftest.frm

Here s the code! Too many people ask for this Using this code you can save an image item as a jpeg

VERSION 5.00
Begin VB.Form frmVBJPEG 
   Caption         =   "Save Picture To JPEG"
   ClientHeight    =   7845
   ClientLeft      =   4410
   ClientTop       =   2070
   ClientWidth     =   6585
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "fTest.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7845
   ScaleWidth      =   6585
   Begin VB.CommandButton cmdSaveBytes 
      Caption         =   "Save Bytes"
      Height          =   315
      Left            =   5100
      TabIndex        =   8
      Top             =   3480
      Width           =   1395
   End
   Begin VB.CommandButton cmdOpenBytes 
      Caption         =   "Open Bytes"
      Height          =   315
      Left            =   5100
      TabIndex        =   7
      Top             =   3120
      Width           =   1395
   End
   Begin VB.TextBox txtQuality 
      Height          =   315
      Left            =   5100
      TabIndex        =   5
      Text            =   "90"
      Top             =   1320
      Width           =   1395
   End
   Begin VB.CommandButton cmdSaveStdPic 
      Caption         =   "&Save..."
      Height          =   315
      Left            =   5100
      TabIndex        =   4
      Top             =   5700
      Width           =   1395
   End
   Begin VB.PictureBox picTest 
      AutoSize        =   -1  'True
      Height          =   1050
      Left            =   180
      Picture         =   "fTest.frx":1272
      ScaleHeight     =   990
      ScaleWidth      =   4440
      TabIndex        =   3
      Top             =   5700
      Width           =   4500
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "&Save..."
      Enabled         =   0   'False
      Height          =   315
      Left            =   5100
      TabIndex        =   2
      Top             =   900
      Width           =   1395
   End
   Begin VB.CommandButton cmdPaint 
      Caption         =   "&Refresh"
      Enabled         =   0   'False
      Height          =   315
      Left            =   5100
      TabIndex        =   1
      Top             =   480
      Width           =   1395
   End
   Begin VB.CommandButton cmdOpen 
      Caption         =   "&Open..."
      Height          =   315
      Left            =   5100
      TabIndex        =   0
      Top             =   60
      Width           =   1395
   End
   Begin VB.Label lblQuality 
      Caption         =   "Quality - 1 - 100.  1 is lowest quality/highest compression.  Use values > 50 for reasonable results."
      Height          =   1335
      Left            =   5100
      TabIndex        =   6
      Top             =   1680
      Width           =   1395
   End
End
Attribute VB_Name = "frmVBJPEG"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cDib As New cDIBSection

Private Sub cmdOpen_Click()
Dim sFile As String
   If VBGetOpenFileName(sFile, , , , , , "JPEG Files (*.JPG)|*.JPG|All Files (*.*)|*.*", 1, , , "JPG", Me.hwnd) Then
      Me.Cls
      If LoadJPG(m_cDib, sFile) Then
         ' so we can see it:
         cmdPaint.Enabled = True
         cmdSave.Enabled = True
         cmdPaint_Click
      Else
         cmdPaint.Enabled = False
         cmdSave.Enabled = False
         MsgBox "Failed to load the file '" & sFile '", vbInformation
      End If
   End If
End Sub

Private Sub cmdOpenBytes_Click()
Dim lPtr As Long
Dim lSize As Long
Dim iFile As Integer
Dim sFile As String
   
   ' This sample uses a file to get the data into memory:
   sFile = App.Path & "\test.jpg"
   iFile = FreeFile
   Open sFile For Binary Access Read Lock Write As #iFile
   lSize = LOF(iFile)
   ReDim b(0 To lSize - 1) As Byte
   Get #iFile, , b()
   Close #iFile
   
   ' And then gets a pointer to the file:
   lPtr = VarPtr(b(0))
   
   If LoadJPGFromPtr(m_cDib, lPtr, lSize) Then
      cmdPaint.Enabled = True
      cmdPaint_Click
   Else
      MsgBox "Failed to load from the file '" & sFile '", vbInformation
   End If
   
End Sub

Private Sub cmdPaint_Click()
   m_cDib.PaintPicture Me.hdc
End Sub

Private Function plQuality() As Long
   On Error Resume Next
   plQuality = CLng(txtQuality.Text)
   If Not Err.Number = 0 Then
      txtQuality.Text = "90"
      plQuality = 90
   End If
End Function
Private Sub cmdSave_Click()
Dim sI As String
   If VBGetSaveFileName(sI, , , "JPEG Files (*.JPG)|*.JPG|All Files (*.*)|*.*", , , , "JPG", Me.hwnd) Then
      If SaveJPG(m_cDib, sI, plQuality()) Then
         ' OK!
      Else
         MsgBox "Failed to save the picture to the file: '" & sI & "'", vbExclamation
      End If
   End If
End Sub

Private Sub cmdSaveBytes_Click()
Dim b() As Byte
Dim lBufSize As Long
Dim lPtr As Long
   
   ' To save to a byte array, we first need to create
   ' a buffer which will be at least large enough to
   ' hold the image.  Here I create a buffer the same
   ' size as the DIB bits divide by 4 (seems about right)
   ReDim b(0 To m_cDib.Height * m_cDib.BytesPerScanLine / 4) As Byte
   ' Get a pointer to the buffer:
   lPtr = VarPtr(b(0))
   ' Pass in the buffer size:
   lBufSize = UBound(b) - 1
   If SaveJPGToPtr(m_cDib, lPtr, lBufSize) Then
   
      ' If we succeed, then lBufSize will be set to the actual
      ' size of the JPG in bytes, so we can trim the image:
      ReDim Preserve b(0 To lBufSize - 1) As Byte
      
      
      ' Just to prove that worked, load the image back in
      ' again from the buffer!
      lPtr = VarPtr(b(0))
      If LoadJPGFromPtr(m_cDib, lPtr, lBufSize) Then
         Debug.Print "Ok!"
      End If
   End If
   
End Sub

Private Sub cmdSaveStdPic_Click()
Dim sI As String
Dim c As New cDIBSection
Dim i As Long

   Set c = New cDIBSection
   c.CreateFromPicture picTest.Picture
   
   sI = App.Path & "\Tempvb.jpg"
   If VBGetSaveFileName(sI, , , "JPEG Files (*.JPG)|*.JPG|All Files (*.*)|*.*", 1, , , "JPG", Me.hwnd) Then
      If SaveJPG(c, sI) Then
         ' OK!
      Else
         MsgBox "Failed to save the picture to the file: '" & sI & "'", vbExclamation
      End If
   End If
   
End Sub

Private Sub txtQuality_KeyPress(KeyAscii As Integer)
   If KeyAscii = 8 Then
   ElseIf KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Then
   Else
      KeyAscii = 0
   End If
End Sub