Solved

BMP => Gif

Posted on 2000-03-31
7
424 Views
Last Modified: 2013-11-19
is there a way to do this using APIs or something?
0
Comment
Question by:ThaSmartUno
  • 3
  • 3
7 Comments
 
LVL 7

Expert Comment

by:Vbmaster
ID: 2675069
Saving images in GIF format is a big no-no. Read more about the licensing **** at...

   http://www.cloanto.com/users/mcb/19950127giflzw.html

You can convert to JPG format for free, using a dll from intel, you can find source code and the dll at...

   http://www.vbaccelerator.com/codelib/gfx/vbjpeg.htm
0
 
LVL 10

Author Comment

by:ThaSmartUno
ID: 2675092
so using the jpg is there a way to go from bmp to jpg?
0
 
LVL 10

Author Comment

by:ThaSmartUno
ID: 2675373
Adjusted points from 50 to 100
0
Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

 
LVL 3

Accepted Solution

by:
HATCHET earned 100 total points
ID: 2675377
'__________________________________________________________
'
'     PUT THIS IN MODULE :
'__________________________________________________________

Option Explicit

'===================================================================================
' Filename    : modJPEG.bas
' Author      : Steve McMahon
' Date        : 15 March 1999
' Requires    : cJPEG by vbAccelerator (formerly cDIBSection.cls)
'               IJL.DLL (Intel)
'
' Description : This module is intended as an easy interface to Intel's IJL
'               (Intel JPG Library) for use in Visual Basic 5.0 / 6.0
'
' NOTE        : The JPEG_Show function is used to display the loaded JPEG.
'               However, if you set the AutoRedraw property of the object
'               showing the picture to TRUE, the picture will not correctly
'               be displayed.  And if you set the AutoRedraw property to
'               FALSE and then minimize the form it's in or put another
'               window infront of it... then bring the focus back to the
'               form containing the picture, the picture disapears.
'               THE WORK AROUND is to put the JPEG_Show in the Paint event
'               of the object containing the picture.
'
'-----------------------------------------------------------------------------------
' vbAccelerator Copyright© 1999 by Steve McMahon (http://vbaccelerator.com)
' IJL.DLL Copyright© 1999 by Intel
'
' IMPORTANT   : Intel is not responsible for any errors in this code, and
'               should not be mentioned in any Help, About, or support in
'               any product using the Intel library
'
'===================================================================================

Public Const GMEM_DDESHARE = &H2000
Public Const GMEM_DISCARDABLE = &H100
Public Const GMEM_DISCARDED = &H4000
Public Const GMEM_FIXED = &H0
Public Const GMEM_INVALID_HANDLE = &H8000
Public Const GMEM_LOCKCOUNT = &HFF
Public Const GMEM_MODIFY = &H80
Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_NOCOMPACT = &H10
Public Const GMEM_NODISCARD = &H20
Public Const GMEM_NOT_BANKED = &H1000
Public Const GMEM_NOTIFY = &H4000
Public Const GMEM_SHARE = &H2000
Public Const GMEM_VALID_FLAGS = &H7F72
Public Const GMEM_ZEROINIT = &H40
Public Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Enum IJLERR
  ' The following "error" values indicate an "OK" condition.
  IJL_OK = 0
  IJL_INTERRUPT_OK = 1
  IJL_ROI_OK = 2

  ' The following "error" values indicate an error has occurred.
  IJL_EXCEPTION_DETECTED = -1
  IJL_INVALID_ENCODER = -2
  IJL_UNSUPPORTED_SUBSAMPLING = -3
  IJL_UNSUPPORTED_BYTES_PER_PIXEL = -4
  IJL_MEMORY_ERROR = -5
  IJL_BAD_HUFFMAN_TABLE = -6
  IJL_BAD_QUANT_TABLE = -7
  IJL_INVALID_JPEG_PROPERTIES = -8
  IJL_ERR_FILECLOSE = -9
  IJL_INVALID_FILENAME = -10
  IJL_ERROR_EOF = -11
  IJL_PROG_NOT_SUPPORTED = -12
  IJL_ERR_NOT_JPEG = -13
  IJL_ERR_COMP = -14
  IJL_ERR_SOF = -15
  IJL_ERR_DNL = -16
  IJL_ERR_NO_HUF = -17
  IJL_ERR_NO_QUAN = -18
  IJL_ERR_NO_FRAME = -19
  IJL_ERR_MULT_FRAME = -20
  IJL_ERR_DATA = -21
  IJL_ERR_NO_IMAGE = -22
  IJL_FILE_ERROR = -23
  IJL_INTERNAL_ERROR = -24
  IJL_BAD_RST_MARKER = -25
  IJL_THUMBNAIL_DIB_TOO_SMALL = -26
  IJL_THUMBNAIL_DIB_WRONG_COLOR = -27
  IJL_RESERVED = -99
End Enum

Private Enum IJLIOTYPE
  IJL_SETUP = -1&
 
  ' Read JPEG parameters (i.e., height, width, channels, sampling, etc.) from a JPEG bit stream.
  IJL_JFILE_READPARAMS = 0&
  IJL_JBUFF_READPARAMS = 1&
 
  ' Read a JPEG Interchange Format image.
  IJL_JFILE_READWHOLEIMAGE = 2&
  IJL_JBUFF_READWHOLEIMAGE = 3&
 
  ' Read JPEG tables from a JPEG Abbreviated Format bit stream.
  IJL_JFILE_READHEADER = 4&
  IJL_JBUFF_READHEADER = 5&
 
  ' Read image info from a JPEG Abbreviated Format bit stream.
  IJL_JFILE_READENTROPY = 6&
  IJL_JBUFF_READENTROPY = 7&
 
  ' Write an entire JFIF bit stream.
  IJL_JFILE_WRITEWHOLEIMAGE = 8&
  IJL_JBUFF_WRITEWHOLEIMAGE = 9&
 
  ' Write a JPEG Abbreviated Format bit stream.
  IJL_JFILE_WRITEHEADER = 10&
  IJL_JBUFF_WRITEHEADER = 11&
 
  ' Write image info to a JPEG Abbreviated Format bit stream.
  IJL_JFILE_WRITEENTROPY = 12&
  IJL_JBUFF_WRITEENTROPY = 13&
 
  '--------  Scaled Decoding Options  --------
 
  ' Reads a JPEG image scaled to 1/2 size.
  IJL_JFILE_READONEHALF = 14&
  IJL_JBUFF_READONEHALF = 15&
 
  ' Reads a JPEG image scaled to 1/4 size.
  IJL_JFILE_READONEQUARTER = 16&
  IJL_JBUFF_READONEQUARTER = 17&
 
  ' Reads a JPEG image scaled to 1/8 size.
  IJL_JFILE_READONEEIGHTH = 18&
  IJL_JBUFF_READONEEIGHTH = 19&
 
  ' Reads an embedded thumbnail from a JFIF bit stream.
  IJL_JFILE_READTHUMBNAIL = 20&
  IJL_JBUFF_READTHUMBNAIL = 21&
End Enum

Private Type JPEG_CORE_PROPERTIES_VB
  UseJPEGPROPERTIES As Long          ' default = 0
 
  ' DIB specific I/O data specifiers
  DIBBytes As Long                   ' default = NULL 4
  DIBWidth As Long                   ' default = 0 8
  DIBHeight As Long                  ' default = 0 12
  DIBPadBytes As Long                ' default = 0 16
  DIBChannels As Long                ' default = 3 20
  DIBColor As Long                   ' default = IJL_BGR 24
  DIBSubsampling As Long             ' default = IJL_NONE 28
 
  ' JPEG specific I/O data specifiers
  JPGFile As Long                    ' LPTSTR  JPGFile 32 default = NULL
  JPGBytes As Long                   ' default = NULL 36
  JPGSizeBytes As Long               ' default = 0 40
  JPGWidth As Long                   ' default = 0 44
  JPGHeight As Long                  ' default = 0 48
  JPGChannels As Long                ' default = 3
  JPGColor As Long                   ' default = IJL_YCBCR
  JPGSubsampling As Long             ' default = IJL_411
  JPGThumbWidth As Long              ' default = 0
  JPGThumbHeight As Long             ' default = 0
 
  ' JPEG conversion properties
  cConversion_Reqd As Long           ' default = TRUE
  upSampling_Reqd As Long            ' default = TRUE
  jQuality As Long                   ' default = 75 : 100 is my preferred quality setting.
 
  ' Low level properties - 20,000 bytes.  If the whole structure is written
  ' out then VB fails with an obscure error message "Too Many Local Variables"!
  ' These all default if they are not otherwise specified so there is no trouble
  jProps(0 To 19999) As Byte
 
End Type

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function ijlInit Lib "IJL10.DLL" (jcprops As Any) As Long
Private Declare Function ijlFree Lib "IJL10.DLL" (jcprops As Any) As Long
Private Declare Function ijlRead Lib "IJL10.DLL" (jcprops As Any, ByVal ioType As Long) As Long
Private Declare Function ijlWrite Lib "IJL10.DLL" (jcprops As Any, ByVal ioType As Long) As Long
Private Declare Function ijlGetLibVersion Lib "IJL10.DLL" () As Long
Private Declare Function ijlGetErrorString Lib "IJL10.DLL" (ByVal code As Long) As Long

'===================================================================================
' Function that loads the specified JPG file into the variable specified
'-----------------------------------------------------------------------------------
'
' Example Use:
' ------------
'
' Dim cJPEGPicture As New cJPEG
' If JPEG_Load(cJPEGPicture, App.Path & "\Test.jpg") Then
'   JPEG_Show Picture1, cJPEGPicture
' End If
'
'===================================================================================

Public Function JPEG_Load(ByRef VariableToLoadInto As cJPEG, FilePath As String) As Boolean
On Error GoTo ErrorTrap
 
  Dim ReturnValue As Long
  Dim TheJPEG As JPEG_CORE_PROPERTIES_VB
  Dim TheFile() As Byte
  Dim ThePointer As Long
  Dim TheWidth As Long
  Dim TheHeight As Long
 
  ' Make sure the file specified exists
  If Dir(FilePath) = "" Then
    MsgBox FilePath & Chr(13) & Chr(13) & "This file does not seem to exist anymore.  Make sure it was not renamed, moved, or deleted and that it's HIDDEN property is not set.", vbOKOnly + vbExclamation, "  File Not Found"
    Exit Function
  End If
 
  ' Initialize the variable
  ReturnValue = ijlInit(TheJPEG)
 
  If ReturnValue = IJL_OK Then
   
    VariableToLoadInto.PictureLoaded = False
   
    ' Write the filename to the jcprops.JPGFile member
    TheFile = StrConv(FilePath, vbFromUnicode)
    ReDim Preserve TheFile(0 To UBound(TheFile) + 1) As Byte
    TheFile(UBound(TheFile)) = 0
    ThePointer = VarPtr(TheFile(0))
    CopyMemory TheJPEG.JPGFile, ThePointer, 4
   
    ' Read the JPEG file parameters
    ReturnValue = ijlRead(TheJPEG, IJL_JFILE_READPARAMS)
    If ReturnValue <> IJL_OK Then
     
      ' Error occured
      MsgBox "Failed to read JPG", vbExclamation
    Else
     
      ' Get the JPGWidth & JPGHeight member values
      TheWidth = TheJPEG.JPGWidth
      TheHeight = TheJPEG.JPGHeight
     
      ' Create a buffer of sufficient size to hold the image:
      If VariableToLoadInto.Create(TheWidth, TheHeight) Then
       
        ' Store DIBWidth
        TheJPEG.DIBWidth = TheWidth
       
        ' Very important - tell IJL how many bytes extra there
        ' are on each DIB scan line to pad to 32 bit boundaries:
        TheJPEG.DIBPadBytes = VariableToLoadInto.BytesPerScanLine - TheWidth * 3
       
        ' Store DIBHeight
        TheJPEG.DIBHeight = -TheHeight
       
        ' Store Channels
        TheJPEG.DIBChannels = 3&
       
        ' Store DIBBytes (pointer to uncompressed JPG data)
        TheJPEG.DIBBytes = VariableToLoadInto.DIBSectionBitsPtr
       
        ' Now decompress the JPG into the DIBSection
        ReturnValue = ijlRead(TheJPEG, IJL_JFILE_READWHOLEIMAGE)
        If ReturnValue = IJL_OK Then
          ' Process complete.
          ' VariableToLoadInto now contains the uncompressed JPG.
          VariableToLoadInto.PictureLoaded = True
          JPEG_Load = True
        Else
          ' Error Occured
          MsgBox "Cannot read Image Data from file.", vbExclamation
        End If
      Else
        ' Failed to create the DIB
        MsgBox "Failed to create the picture.", vbOKOnly + vbExclamation, "  Error"
      End If
    End If
   
    ' Ensure we have freed memory
    ijlFree TheJPEG
  Else
    ' Error Occured
    MsgBox "Failed to initialise the IJL library: " & CStr(ReturnValue), vbExclamation
  End If
 
  Exit Function
 
ErrorTrap:
 
  If Err.Number = 0 Then      ' No Error
    Resume Next
  ElseIf Err.Number = 20 Then ' Resume Without Error
    Resume Next
  Else                        ' Other Error
    MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, "  Error  -  " & Err.Description
    Err.Clear
    Exit Function
  End If
 
End Function

'===================================================================================
' Function that saves the loaded JPG file out to the specified file
'-----------------------------------------------------------------------------------
'
' Example Use:
' ------------
'
' Dim cJPG As New cJPEG
' cJPG.CreateFromPicture Picture1.Picture
' JPEG_Save cJPG, App.Path & "\Test.jpg"
'
'===================================================================================

Public Function JPEG_Save(ByRef VariableToSaveFrom As cJPEG, FilePath As String, Optional SaveQuality As Long = 100, Optional PromptToOverwrite As Boolean = False) As Boolean
On Error Resume Next
 
  Dim MyAnswer As VbMsgBoxResult
  Dim ReturnValue As Long
  Dim TheJPEG As JPEG_CORE_PROPERTIES_VB
  Dim TheFile() As Byte
  Dim ThePointer As Long
 
  ' Check if there's a JPG file loaded to display
  If VariableToSaveFrom.PictureLoaded = False Then
    MsgBox "No picture loaded to save.", vbOKOnly + vbExclamation, "  No Picture Available To Save"
    Exit Function
  End If
 
  ' If the file already exists, prompt to overwrite it
  If Dir(FilePath) <> "" Then
    If PromptToOverwrite = True Then
      MyAnswer = MsgBox(FilePath & Chr(13) & "This file already exists." & Chr(13) & Chr(13) & "Replace existing file?", vbYesNo + vbExclamation, "  Confirm File Overwrite")
      If MyAnswer <> vbYes Then
        Exit Function
      End If
    End If
  End If
 
  ' Make sure that the file does not exist
  Kill FilePath
 
  On Error GoTo ErrorTrap
 
  ' Make sure that the save quality is not set to an invalid value
  If SaveQuality < 1 Then
    SaveQuality = 1
  ElseIf SaveQuality > 100 Then
    SaveQuality = 100
  End If
 
  ' Initialize the variable passed
  ReturnValue = ijlInit(TheJPEG)
  If ReturnValue = IJL_OK Then
   
    '------------- Set up the DIB information ------------
   
    ' Store DIBWidth
    TheJPEG.DIBWidth = VariableToSaveFrom.Width
   
    ' Store DIBHeight
    TheJPEG.DIBHeight = -VariableToSaveFrom.Height
   
    ' Store DIBBytes (pointer to uncompressed JPG data)
    TheJPEG.DIBBytes = VariableToSaveFrom.DIBSectionBitsPtr
   
    ' Very important: tell IJL how many bytes extra there
    ' are on each DIB scan line to pad to 32 bit boundaries
    TheJPEG.DIBPadBytes = VariableToSaveFrom.BytesPerScanLine - VariableToSaveFrom.Width * 3
   
    '------------ Set up the JPEG information -------------
   
    ' Store JPGFile
    TheFile = StrConv(FilePath, vbFromUnicode)
    ReDim Preserve TheFile(0 To UBound(TheFile) + 1) As Byte
    TheFile(UBound(TheFile)) = 0
    ThePointer = VarPtr(TheFile(0))
    CopyMemory TheJPEG.JPGFile, ThePointer, 4
   
    ' Store JPGWidth & JPGHeight member values
    TheJPEG.JPGWidth = VariableToSaveFrom.Width
    TheJPEG.JPGHeight = VariableToSaveFrom.Height
   
    ' Set the quality & compression to save
    TheJPEG.jQuality = SaveQuality
   
    ' Write the image
    ReturnValue = ijlWrite(TheJPEG, IJL_JFILE_WRITEWHOLEIMAGE)
    If ReturnValue = IJL_OK Then
      JPEG_Save = True
    Else
      ' Error Occured
      MsgBox "Failed to save to JPG", vbExclamation
    End If
   
    ' Ensure we have freed memory
    ijlFree TheJPEG
  Else
    ' Error Occured
    MsgBox "Failed to initialise the IJL library: " & CStr(ReturnValue), vbExclamation
  End If
 
  Exit Function
 
ErrorTrap:
 
  If Err.Number = 0 Then      ' No Error
    Resume Next
  ElseIf Err.Number = 20 Then ' Resume Without Error
    Resume Next
  Else                        ' Other Error
    MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, "  Error  -  " & Err.Description
    Err.Clear
    Exit Function
  End If
 
End Function

'===================================================================================
' This function takes a given object and displays the loaded JPEG picture in it.
' NOTE : This will only work with objects that have the "hDC" property like
'        Form, PictureBox, Printer, Property Page, UserControl, UserDocument, etc.
'-----------------------------------------------------------------------------------
'
' Example Use:
' ------------
'
' JPEG_Show Picture1, cJPEGPicture
'
'===================================================================================

Public Function JPEG_Show(ByRef DisplayObject As Object, JPEGVariable As cJPEG) As Boolean
On Error GoTo ErrorTrap
 
  ' Check if there's a JPG file loaded to display
  If JPEGVariable.PictureLoaded = False Then
    Exit Function
  End If
 
  ' Clear the display area before displaying it
  DisplayObject.Cls
 
  ' Paint the picture on the display area
  JPEGVariable.PaintPicture DisplayObject.hDC
  JPEG_Show = True
 
  Exit Function
 
ErrorTrap:
 
  If Err.Number = 0 Then       ' No Error
    Resume Next
  ElseIf Err.Number <> 20 Then ' Resume Without Error
    Resume Next
  Else                         ' Other Error
    JPEG_Show = False
    Err.Clear
    Exit Function
  End If
 
End Function
 
0
 
LVL 3

Expert Comment

by:HATCHET
ID: 2675379
'__________________________________________________________
'
'     PUT THIS IN CLASS MODULE :
'__________________________________________________________

Option Explicit

' ---- Constants ----
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 '  Color table in RGBs
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8

' ---- Enumerations / Types ----
Private Type SAFEARRAYBOUND
  cElements       As Long
  lLbound         As Long
End Type

Private Type SAFEARRAY2D
  cDims           As Integer
  fFeatures       As Integer
  cbElements      As Long
  cLocks          As Long
  pvData          As Long
  Bounds(0 To 1)  As SAFEARRAYBOUND
End Type

Private Type RGBQUAD
  rgbBlue         As Byte
  rgbGreen        As Byte
  rgbRed          As Byte
  rgbReserved     As Byte
End Type

Private Type BITMAPINFOHEADER '40 bytes
  biSize          As Long
  biWidth         As Long
  biHeight        As Long
  biPlanes        As Integer
  biBitCount      As Integer
  biCompression   As Long
  biSizeImage     As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed       As Long
  biClrImportant  As Long
End Type

Private Type BITMAPINFO
  bmiHeader       As BITMAPINFOHEADER
  bmiColors       As RGBQUAD
End Type

Private Type BITMAP
  bmType          As Long
  bmWidth         As Long
  bmHeight        As Long
  bmWidthBytes    As Long
  bmPlanes        As Integer
  bmBitsPixel     As Integer
  bmBits          As Long
End Type

' ---- API Functions / Subs ----
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function LoadImage Lib "USER32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () 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 VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "USER32" () As Long
Private Declare Function SetClipboardData Lib "USER32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "USER32" () As Long

' Note : The following declaration is not the VB API Viewer - Modify lplpVoid to be Byref so we get the pointer back
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

' ---- Variables ----

Private m_Loaded  As Boolean    ' Tells weather the class contains a loaded picture
Private m_hDIb    As Long       ' Handle to the current DIBSection
Private m_hBmpOld As Long       ' Handle to the old bitmap in the DC, for clear up
Private m_hDC     As Long       ' Handle to the Device context holding the DIBSection
Private m_lPtr    As Long       ' Address of memory pointing to the DIBSection's bits
Private m_tBI     As BITMAPINFO ' Type containing the Bitmap information


' --------------------  CLASS EVENTS  --------------------

Private Sub Class_Terminate()
 
  ClearUp
 
End Sub


' --------------------  CLASS PROPERTIES  --------------------

Public Property Get PictureLoaded() As Boolean
 
  PictureLoaded = m_Loaded
 
End Property

Public Property Let PictureLoaded(ByVal NewValue As Boolean)
 
  m_Loaded = NewValue
 
End Property

Public Property Get DIBSectionBitsPtr() As Long
On Error Resume Next
 
  DIBSectionBitsPtr = m_lPtr
 
End Property

Public Property Get hDC() As Long
On Error Resume Next
 
  hDC = m_hDC
 
End Property

Public Property Get hDib() As Long
On Error Resume Next
 
  hDib = m_hDIb
 
End Property

Public Property Get Height() As Long
On Error Resume Next
 
  Height = m_tBI.bmiHeader.biHeight
 
End Property

Public Property Get Width() As Long
On Error Resume Next
 
  Width = m_tBI.bmiHeader.biWidth
 
End Property



' --------------------  CLASS METHODS  --------------------

' Copy picture to clipboard as a bitmap
Public Function CopyToClipboard() As Boolean
On Error Resume Next
 
  Dim lhDCDesktop As Long
  Dim lhDC As Long
  Dim lhBmpOld As Long
  Dim hObj As Long
  Dim lFmt As Long
  Dim B() As Byte
  Dim tBI As BITMAPINFO
  Dim lPtr As Long
  Dim hDibCopy As Long

  lhDCDesktop = GetDC(GetDesktopWindow())
  If (lhDCDesktop <> 0) Then
    lhDC = CreateCompatibleDC(lhDCDesktop)
    If (lhDC <> 0) Then
     
      ' Create a compatible bitmap and copy to the clipboard
      hObj = CreateCompatibleBitmap(lhDCDesktop, Width, Height)
      If (hObj <> 0) Then
        lhBmpOld = SelectObject(lhDC, hObj)
        PaintPicture lhDC
        SelectObject lhDC, lhBmpOld
        lFmt = CF_BITMAP
       
        ' Now set the clipboard to the bitmap
        If (OpenClipboard(0) <> 0) Then
          EmptyClipboard
          If (SetClipboardData(lFmt, hObj) <> 0) Then
            CopyToClipboard = True
          End If
          CloseClipboard
        End If
      End If
      DeleteDC lhDC
    End If
    DeleteDC lhDCDesktop
  End If

End Function

Public Function CreateDIB(ByVal lhDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long) As Boolean
On Error Resume Next
 
  With m_tBI.bmiHeader
    .biSize = Len(m_tBI.bmiHeader)
    .biWidth = lWidth
    .biHeight = lHeight
    .biPlanes = 1
    .biBitCount = 24
    .biCompression = BI_RGB
    .biSizeImage = BytesPerScanLine * .biHeight
  End With
 
  hDib = CreateDIBSection(lhDC, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)
  CreateDIB = (hDib <> 0)
 
End Function

Public Function CreateFromPicture(ByRef PictureSource As StdPicture)
On Error GoTo ErrorTrap
 
  Dim lhDC As Long
  Dim lhDCDesktop As Long
  Dim lhBmpOld As Long
  Dim tBMP As BITMAP
 
  m_Loaded = False
 
  GetObjectAPI PictureSource.handle, Len(tBMP), tBMP
  If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
    lhDCDesktop = GetDC(GetDesktopWindow())
    If (lhDCDesktop <> 0) Then
      lhDC = CreateCompatibleDC(lhDCDesktop)
      DeleteDC lhDCDesktop
      If (lhDC <> 0) Then
        lhBmpOld = SelectObject(lhDC, PictureSource.handle)
        LoadPictureBlt lhDC
        SelectObject lhDC, lhBmpOld
        DeleteObject lhDC
      End If
    End If
  End If
 
  m_Loaded = True
 
  Exit Function
 
ErrorTrap:
 
  Err.Clear
 
End Function

Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long) As Boolean
On Error Resume Next
 
  ClearUp
  m_hDC = CreateCompatibleDC(0)
  If (m_hDC <> 0) Then
    If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
      m_hBmpOld = SelectObject(m_hDC, m_hDIb)
      Create = True
    Else
      DeleteObject m_hDC
      m_hDC = 0
    End If
  End If
 
End Function

Public Property Get BytesPerScanLine() As Long
On Error Resume Next
 
  ' Scans must align on dword boundaries:
  BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
 
End Property

Public Sub LoadPictureBlt(ByVal lhDC As Long, Optional ByVal lSrcLeft As Long = 0, Optional ByVal lSrcTop As Long = 0, Optional ByVal lSrcWidth As Long = -1, Optional ByVal lSrcHeight As Long = -1, Optional ByVal eRop As RasterOpConstants = vbSrcCopy)
On Error Resume Next
 
  If lSrcWidth < 0 Then
    lSrcWidth = m_tBI.bmiHeader.biWidth
  End If
 
  If lSrcHeight < 0 Then
    lSrcHeight = m_tBI.bmiHeader.biHeight
  End If
 
  BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
 
End Sub

Public Sub PaintPicture(ByVal lhDC As Long, Optional ByVal lDestLeft As Long = 0, Optional ByVal lDestTop As Long = 0, Optional ByVal lDestWidth As Long = -1, Optional ByVal lDestHeight As Long = -1, Optional ByVal lSrcLeft As Long = 0, Optional ByVal lSrcTop As Long = 0, Optional ByVal eRop As RasterOpConstants = vbSrcCopy)
On Error Resume Next
 
  If (lDestWidth < 0) Then
    lDestWidth = m_tBI.bmiHeader.biWidth
  End If
 
  If (lDestHeight < 0) Then
    lDestHeight = m_tBI.bmiHeader.biHeight
  End If
 
  BitBlt lhDC, lDestLeft, lDestTop, lDestWidth, lDestHeight, m_hDC, lSrcLeft, lSrcTop, eRop
 
End Sub

Public Sub RandomiseBits(Optional ByVal bGray As Boolean = False)
On Error Resume Next

  Dim bDib() As Byte
  Dim X As Long, Y As Long
  Dim lC As Long
  Dim tSA As SAFEARRAY2D
  Dim xEnd As Long
   
  ' Get the bits in the from DIB section
  With tSA
    .cbElements = 1
    .cDims = 2
    .Bounds(0).lLbound = 0
    .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
    .Bounds(1).lLbound = 0
    .Bounds(1).cElements = BytesPerScanLine()
    .pvData = m_lPtr
  End With
  CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
 
  ' random:
  Randomize Timer
 
  xEnd = (Width - 1) * 3
  If (bGray) Then
    For Y = 0 To m_tBI.bmiHeader.biHeight - 1
      For X = 0 To xEnd Step 3
        lC = Rnd * 255
        bDib(X, Y) = lC
        bDib(X + 1, Y) = lC
        bDib(X + 2, Y) = lC
      Next X
    Next Y
  Else
    For X = 0 To xEnd Step 3
      For Y = 0 To m_tBI.bmiHeader.biHeight - 1
        bDib(X, Y) = 0
        bDib(X + 1, Y) = Rnd * 255
        bDib(X + 2, Y) = Rnd * 255
      Next Y
    Next X
  End If
 
  ' Clear the temporary array descriptor
  ' NOTE : This does not appear to be necessary, but for safety do it anyway
  CopyMemory ByVal VarPtrArray(bDib), 0&, 4
 
End Sub

Public Sub ClearUp()
On Error Resume Next
 
  m_Loaded = False
 
  If (m_hDC <> 0) Then
    If (m_hDIb <> 0) Then
      SelectObject m_hDC, m_hBmpOld
      DeleteObject m_hDIb
    End If
    DeleteObject m_hDC
  End If
 
  m_hDC = 0
  m_hDIb = 0
  m_hBmpOld = 0
  m_lPtr = 0
 
End Sub

Public Function Resample(ByVal lNewHeight As Long, ByVal lNewWidth As Long) As cJPEG
On Error Resume Next
 
  Dim cDib As cJPEG
   
  Set cDib = New cJPEG
  If cDib.Create(lNewWidth, lNewHeight) Then
    If (lNewWidth <> m_tBI.bmiHeader.biWidth) Or (lNewHeight <> m_tBI.bmiHeader.biHeight) Then
      ' Change in size, do resample:
      ResampleDib cDib
    Else
      ' No size change so just return a copy:
      cDib.LoadPictureBlt m_hDC
    End If
    Set Resample = cDib
  End If
 
End Function

Private Function ResampleDib(ByRef cDibTo As cJPEG) As Boolean
On Error Resume Next

  Dim bDibFrom() As Byte
  Dim bDibTo() As Byte
  Dim tSAFrom As SAFEARRAY2D
  Dim tSATo As SAFEARRAY2D
  Dim xScale As Single
  Dim yScale As Single
  Dim X As Long
  Dim Y As Long
  Dim xEnd As Long
  Dim xOut As Long
  Dim fX As Single
  Dim fY As Single
  Dim ifY As Long
  Dim ifX As Long
  Dim dX As Single
  Dim dy As Single
  Dim R As Long
  Dim R1 As Single
  Dim R2 As Single
  Dim R3 As Single
  Dim R4 As Single
  Dim G As Long
  Dim G1 As Single
  Dim G2 As Single
  Dim G3 As Single
  Dim G4 As Single
  Dim B As Long
  Dim B1 As Single
  Dim B2 As Single
  Dim B3 As Single
  Dim B4 As Single
  Dim iR1 As Long
  Dim iG1 As Long
  Dim iB1 As Long
  Dim iR2 As Long
  Dim iG2 As Long
  Dim iB2 As Long
 
  ' Get the bits in the from DIB section:
  With tSAFrom
    .cbElements = 1
    .cDims = 2
    .Bounds(0).lLbound = 0
    .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
    .Bounds(1).lLbound = 0
    .Bounds(1).cElements = BytesPerScanLine()
    .pvData = m_lPtr
  End With
  CopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4
 
  ' Get the bits in the to DIB section:
  With tSATo
    .cbElements = 1
    .cDims = 2
    .Bounds(0).lLbound = 0
    .Bounds(0).cElements = cDibTo.Height
    .Bounds(1).lLbound = 0
    .Bounds(1).cElements = cDibTo.BytesPerScanLine()
    .pvData = cDibTo.DIBSectionBitsPtr
  End With
  CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4
 
  xScale = (Width - 1) / cDibTo.Width
  yScale = (Height - 1) / cDibTo.Height
  xEnd = cDibTo.Width - 1
   
  For Y = 0 To cDibTo.Height - 1
    fY = Y * yScale
    ifY = Int(fY)
    dy = fY - ifY
    For X = 0 To xEnd
      fX = X * xScale
      ifX = Int(fX)
      dX = fX - ifX
      ifX = ifX * 3
     
      ' Interpolate using the four nearest pixels in the source
      B1 = bDibFrom(ifX, ifY): G1 = bDibFrom(ifX + 1, ifY): R1 = bDibFrom(ifX + 2, ifY)
      B2 = bDibFrom(ifX + 3, ifY): G2 = bDibFrom(ifX + 4, ifY): R2 = bDibFrom(ifX + 5, ifY)
      B3 = bDibFrom(ifX, ifY + 1): G3 = bDibFrom(ifX + 1, ifY + 1): R3 = bDibFrom(ifX + 2, ifY + 1)
      B4 = bDibFrom(ifX + 3, ifY + 1): G4 = bDibFrom(ifX + 4, ifY + 1): R4 = bDibFrom(ifX + 5, ifY + 1)
     
      ' Interplate in x direction:
      iR1 = R1 * (1 - dy) + R3 * dy: iG1 = G1 * (1 - dy) + G3 * dy: iB1 = B1 * (1 - dy) + B3 * dy
      iR2 = R2 * (1 - dy) + R4 * dy: iG2 = G2 * (1 - dy) + G4 * dy: iB2 = B2 * (1 - dy) + B4 * dy
      ' Interpolate in y:
      R = iR1 * (1 - dX) + iR2 * dX: G = iG1 * (1 - dX) + iG2 * dX: B = iB1 * (1 - dX) + iB2 * dX
     
      ' Set output:
      If (R < 0) Then R = 0
      If (R > 255) Then R = 255
      If (G < 0) Then G = 0
      If (G > 255) Then G = 255
      If (B < 0) Then B = 0
      If (B > 255) Then B = 255
      xOut = X * 3
      bDibTo(xOut, Y) = B
      bDibTo(xOut + 1, Y) = G
      bDibTo(xOut + 2, Y) = R
    Next X
  Next Y
 
  ' Clear the temporary array descriptor
  ' NOTE : This does not appear to be necessary, but for safety do it anyway
  CopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
  CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4
 
End Function
0
 
LVL 3

Expert Comment

by:HATCHET
ID: 2675385
You also need the file IJL10.DLL from Intel for this code to work.  You can download the above MODULE and CLASS MODULE along with the mentioned .DLL from the following URL :

ftp://ftp.one.net/pub/users/kevinw/VisualBasic/VB Code - Save JPG.zip


HATCHET
0
 
LVL 10

Author Comment

by:ThaSmartUno
ID: 2675390
Thanks
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

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…
Many programs have tried to outwit PowerPoint in terms of technology and skill. These programs, however, still lack several characteristics that PowerPoint has possessed from the start. Here's why PowerPoint replacements won't entirely work for desi…
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…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

743 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

11 Experts available now in Live!

Get 1:1 Help Now