JMA
tuzka.cz
Ing. Jan Matuška tvorba databází a webu kontakt
služby+sw
software
exShop je pohoda!
KOALA
Kniha pošty
projekty
webdesign
o firmě
tipy kolegům
VBA
Dokončit import
FreeImage
ZIPování
TCP/IP
Outlook-přílohy
Access
HWIZ
Zdroje informací
Upload
Z autorské tvorby
Fotografie
Sbírka básní
Plakát
Přečtěte si
Jak a proč jsem se stal křesťanem
Víte, že AHOJ je zkratka?
Poznat Boha, ale jak?
... další přímo na stránkách BTM

VBA: Použití knihovny FreeImage.dll

Jan Matuška 6/2009

V roce 2006 jsem potřeboval pracovat s obrázky, tak jsem hledal a našel kromě knihovny GD, ke které jsem nenašel pořádné příklady pro VBA, knihovnu FreeImage, které splnila vše, co jsem potřeboval. (připomínám, že dělám hlavně v Accessu 2k)

Jak vidíte, už to jsou 3 roky, tak si houby pamatuju všecky finesy, jak jsem to přesně používal. Jestli to někdy zase budu potřebovat a osvěžím si paměť, tak sem třeba dopíšu nějaké návody. Nicméně třeba se vám kód následující třídy bude hodit:

Třída (soubor jmaImageFI.cls):

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "jmaImageFI"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'JMA třída pro práci s obrázky s knihovnou FreeImage.dll
'Copyright (c) 2006 Jan Matuska (www.tuzka.cz) - smíte použít podle licence GPL, BEZ ZÁRUK NA COKOLI!
'060222:
'- vl. SaveAsType ... defaultní nastavení pro metody *Save*
'- uložení do paměti a možnost přečíst velikost či string: MemorySave, MemoryFileSize, MemoryFileString,MemoryClear
'- možnost ponechání originálního naloudovaného DIB obrázku: vl. OriginalRemember a met. Original
'060221:
'- doděláno ošetření chyb do veřejných fcí
'- zvlášť property RescaleMethod
'- nová fce GrayScale místo původní (názvy fcí v knihovně najdu v FreeImage\Dist\FreeImage.lib)
'- doděláno ládování a ukládání z/do paměti (řetězce)
'oprava fcí Save - stejně byla blbost, že se měnila DIB, ta má zůstat a jen kopii připravit pro Save
' 060220 předěláno na třídu, funguje s vezí 3.8.0 FreeImage knihovny

'********************************************************************************
'FImage Control v1.07 for Visual Basic
'Copyright (C) 2005 Simon Nash (aka YetiFoot)
'
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'(at your option) any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'GNU General Public License for more details.
'
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
'
'You can contact the author of this software by e-mail at
'yetifoot@users.sourceforge.net
'
'This software is made available at
'http://sourceforge.net/projects/fimage
'
'Many thanks go to the creators of the freeimage dll which this control utilises.
'For more information visit http://freeimage.sourceforge.net
'
'Thanks to the creators of freeimageocx (http://sourceforge.net/projects/freeimageocx)
'For inspiration and the code for Load/FreeLibrary and the idea to use
'InvertRect, it sped invert up a lot)
'
'Thanks to Manuel Augusto Nogueira dos Santos for his code that is used for
'soften and sharpen.  His 'mFilterG - Graphic Filters' public domain project
'is very useful to show you how to implement filters in VB.  More info on this subject
'which i believe is called 'laplace kernel' filtering, can be found in the
'comp.graphics.algorithms FAQ, which is also very useful, and covers many subjects.
'
'This version uses v3.6.1 of the freeimage dll
'********************************************************************************

Option Explicit

'**********************************
'FreeImage Specific Stuff         *
'**********************************
Private Type FIMEMORY
  data As Long
End Type
'FreeImage Declares
Private Declare Function FreeImage_Allocate Lib "FreeImage.dll" Alias "_FreeImage_Allocate@24" (ByVal Width As Long, ByVal Height As Long, ByVal bpp As Long, Optional ByVal red_mask As Long = 0, Optional ByVal green_mask As Long = 0, Optional ByVal blue_mask As Long = 0) As Long
Private Declare Function FreeImage_GetWidth Lib "FreeImage.dll" Alias "_FreeImage_GetWidth@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_GetHeight Lib "FreeImage.dll" Alias "_FreeImage_GetHeight@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_GetBits Lib "FreeImage.dll" Alias "_FreeImage_GetBits@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_GetInfo Lib "FreeImage.dll" Alias "_FreeImage_GetInfo@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_ConvertTo24Bits Lib "FreeImage.dll" Alias "_FreeImage_ConvertTo24Bits@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_ColorQuantize Lib "FreeImage.dll" Alias "_FreeImage_ColorQuantize@8" (ByVal DIB As Long, ByVal quantize As FREE_IMAGE_QUANTIZE) As Long
Private Declare Function FreeImage_Load Lib "FreeImage.dll" Alias "_FreeImage_Load@12" (ByVal fif As FREE_IMAGE_FORMAT, ByVal FileName As String, Optional ByVal flags As Long = 0) As Long
Private Declare Function FreeImage_Save Lib "FreeImage.dll" Alias "_FreeImage_Save@16" (ByVal fif As FREE_IMAGE_FORMAT, ByVal DIB As Long, ByVal FileName As String, Optional ByVal flags As Long = 0) As Long
Private Declare Sub FreeImage_Unload Lib "FreeImage.dll" Alias "_FreeImage_Unload@4" (ByVal DIB As Long)
Private Declare Function FreeImage_GetFIFFromFilename Lib "FreeImage.dll" Alias "_FreeImage_GetFIFFromFilename@4" (ByVal FileName As String) As FREE_IMAGE_FORMAT
Private Declare Function FreeImage_Rescale Lib "FreeImage.dll" Alias "_FreeImage_Rescale@16" (ByVal DIB As Long, ByVal dst_width As Long, ByVal dst_height As Long, ByVal Filter As FREE_IMAGE_FILTER) As Long
Private Declare Function FreeImage_GetFileType Lib "FreeImage.dll" Alias "_FreeImage_GetFileType@8" (ByVal FileName As String, Optional ByVal size As Long = 0) As FREE_IMAGE_FORMAT
Private Declare Function FreeImage_GetVersion Lib "FreeImage.dll" Alias "_FreeImage_GetVersion@0" () As Long
'DLL_API const char *DLL_CALLCONV FreeImage_GetVersion();
Private Declare Function FreeImage_GetCopyrightMessage Lib "FreeImage.dll" Alias "_FreeImage_GetCopyrightMessage@0" () As Long
'DLL_API const char *DLL_CALLCONV FreeImage_GetCopyrightMessage();
Private Declare Function FreeImage_Invert Lib "FreeImage.dll" Alias "_FreeImage_Invert@4" (ByVal DIB As Long) As Boolean
Private Declare Function FreeImage_ConvertTo8Bits Lib "FreeImage.dll" Alias "_FreeImage_ConvertTo8Bits@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_GetFIFCount Lib "FreeImage.dll" Alias "_FreeImage_GetFIFCount@0" () As Long
Private Declare Function FreeImage_FIFSupportsReading Lib "FreeImage.dll" Alias "_FreeImage_FIFSupportsReading@4" (ByVal fif As FREE_IMAGE_FORMAT) As Long
Private Declare Function FreeImage_FIFSupportsWriting Lib "FreeImage.dll" Alias "_FreeImage_FIFSupportsWriting@4" (ByVal fif As FREE_IMAGE_FORMAT) As Long
Private Declare Function FreeImage_GetFIFExtensionList Lib "FreeImage.dll" Alias "_FreeImage_GetFIFExtensionList@4" (ByVal fif As FREE_IMAGE_FORMAT) As Long
Private Declare Function FreeImage_GetFIFDescription Lib "FreeImage.dll" Alias "_FreeImage_GetFIFDescription@4" (ByVal fif As FREE_IMAGE_FORMAT) As Long
Private Declare Function FreeImage_Dither Lib "FreeImage.dll" Alias "_FreeImage_Dither@8" (ByVal DIB As Long, ByVal algorithm As FREE_IMAGE_DITHER) As Long
Private Declare Function FreeImage_FlipHorizontal Lib "FreeImage.dll" Alias "_FreeImage_FlipHorizontal@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_FlipVertical Lib "FreeImage.dll" Alias "_FreeImage_FlipVertical@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_RotateClassic Lib "FreeImage.dll" Alias "_FreeImage_RotateClassic@12" (ByVal DIB As Long, ByVal Angle As Double) As Long
Private Declare Function FreeImage_RotateEx Lib "FreeImage.dll" Alias "_FreeImage_RotateEx@48" (ByVal DIB As Long, ByVal Angle As Double, ByVal x_shift As Double, ByVal y_shift As Double, ByVal x_origin As Double, ByVal y_origin As Double, ByVal use_mask As Long) As Long
Private Declare Function FreeImage_LockPage Lib "FreeImage.dll" Alias "_FreeImage_LockPage@8" (ByVal BITMAP As Long, ByVal Page As Long) As Long
Private Declare Sub FreeImage_UnlockPage Lib "FreeImage.dll" Alias "_FreeImage_UnlockPage@12" (ByVal BITMAP As Long, ByVal Page As Long, ByVal changed As Long)
Private Declare Function FreeImage_OpenMultiBitmap Lib "FreeImage.dll" Alias "_FreeImage_OpenMultiBitmap@20" (ByVal fif As FREE_IMAGE_FORMAT, ByVal FileName As String, ByVal create_new As Long, ByVal read_only As Long, Optional ByVal keep_cache_in_memory As Long = 0) As Long
Private Declare Function FreeImage_CloseMultiBitmap Lib "FreeImage.dll" Alias "_FreeImage_CloseMultiBitmap@8" (ByVal BITMAP As Long, Optional ByVal flags As Long = 0) As Long
Private Declare Function FreeImage_GetBPP Lib "FreeImage.dll" Alias "_FreeImage_GetBPP@4" (ByVal DIB As Long) As Long
Private Declare Function FreeImage_GetPageCount Lib "FreeImage.dll" Alias "_FreeImage_GetPageCount@4" (ByVal BITMAP As Long) As Long
'JMA 060221 (opsáno z FreeImage\Wrapper\VB6\mfreeimage\MFreeImage.bas):
Private Const SEEK_SET As Long = 0
Private Const SEEK_CUR As Long = 1
Private Const SEEK_END As Long = 2
Private Declare Function FreeImage_OpenMemory Lib "FreeImage.dll" Alias "_FreeImage_OpenMemory@8" (Optional ByRef data As Byte = 0, Optional ByVal size_in_bytes As Long = 0) As Long
Private Declare Function FreeImage_OpenMemoryByPtr Lib "FreeImage.dll" Alias "_FreeImage_OpenMemory@8" (Optional ByVal data_ptr As Long, Optional ByVal size_in_bytes As Long = 0) As Long
Private Declare Sub FreeImage_CloseMemory Lib "FreeImage.dll" Alias "_FreeImage_CloseMemory@4" (ByVal stream As Long)
Private Declare Function FreeImage_LoadFromMemory Lib "FreeImage.dll" Alias "_FreeImage_LoadFromMemory@12" (ByVal fif As FREE_IMAGE_FORMAT, ByVal stream As Long, Optional ByVal flags As Long = 0) As Long
Private Declare Function FreeImage_SaveToMemory Lib "FreeImage.dll" Alias "_FreeImage_SaveToMemory@16" (ByVal fif As FREE_IMAGE_FORMAT, ByVal DIB As Long, ByVal stream As Long, Optional ByVal flags As Long = 0) As Long
Private Declare Function FreeImage_AcquireMemory Lib "FreeImage.dll" Alias "_FreeImage_AcquireMemory@12" (ByVal stream As Long, ByRef data As Long, ByRef size_in_bytes As Long) As Long
Private Declare Function FreeImage_TellMemory Lib "FreeImage.dll" Alias "_FreeImage_TellMemory@4" (ByVal stream As Long) As Long
Private Declare Function FreeImage_SeekMemory Lib "FreeImage.dll" Alias "_FreeImage_SeekMemory@12" (ByVal stream As Long, ByVal offset As Long, ByVal origin As Long) As Long
Private Declare Function FreeImage_ConvertToGreyscale Lib "FreeImage.dll" Alias "_FreeImage_ConvertToGreyscale@4" (ByVal DIB As Long) As Long
''DLL_API FIBITMAP *DLL_CALLCONV FreeImage_ConvertToGreyscale(FIBITMAP *dib)

'Private Declare Function FreeImage_SaveToMemory Lib "FreeImage.dll" Alias "_FreeImage_SaveToMemory@16" (ByVal fif As FREE_IMAGE_FORMAT, ByVal dib As Long, ByVal memory As Long, Optional ByVal flags As Long = 0) As Long
''DLL_API BOOL DLL_CALLCONV FreeImage_SaveToMemory(FREE_IMAGE_FORMAT fif, FIBITMAP *dib,FIMEMORY *stream, int flags FI_DEFAULT(0));
'Private Declare Function FreeImage_OpenMemory Lib "FreeImage.dll" Alias "_FreeImage_OpenMemory@8" (Optional data As Long = 0, Optional ByVal Size As Long = 0) As Long
''DLL_API FIMEMORY *DLL_CALLCONV FreeImage_OpenMemory(BYTE *data FI_DEFAULT(0), DWORD size_in_bytes FI_DEFAULT(0));
'Private Declare Sub FreeImage_CloseMemory Lib "FreeImage.dll" Alias "_FreeImage_CloseMemory@4" (ByVal memory As Long)
''DLL_API void DLL_CALLCONV FreeImage_CloseMemory(FIMEMORY *stream);

'<<< End FreeImage Declares

'FreeImage Enums
Public Enum FREE_IMAGE_FORMAT
  FIF_UNKNOWN = -1
  FIF_BMP = 0
  FIF_ICO = 1
  FIF_JPEG = 2
  FIF_JNG = 3
  FIF_KOALA = 4
  FIF_LBM = 5
  FIF_IFF = FIF_LBM
  FIF_MNG = 6
  FIF_PBM = 7
  FIF_PBMRAW = 8
  FIF_PCD = 9
  FIF_PCX = 10
  FIF_PGM = 11
  FIF_PGMRAW = 12
  FIF_PNG = 13
  FIF_PPM = 14
  FIF_PPMRAW = 15
  FIF_RAS = 16
  FIF_TARGA = 17
  FIF_TIFF = 18
  FIF_WBMP = 19
  FIF_PSD = 20
  FIF_CUT = 21
  FIF_XBM = 22
  FIF_XPM = 23
  FIF_DDS = 24
  FIF_GIF = 25
  FIF_HDR = 26
End Enum
Public Enum FREE_IMAGE_QUANTIZE
  FIQ_WUQUANT = 0
  FIQ_NNQUANT = 1
End Enum
Public Enum FREE_IMAGE_FILTER
  FILTER_BOX = 0
  FILTER_BICUBIC = 1
  FILTER_BILINEAR = 2
  FILTER_BSPLINE = 3
  FILTER_CATMULLROM = 4
  FILTER_LANCZOS3 = 5
End Enum
Public Enum FREE_IMAGE_DITHER
  FID_FS = 0
  FID_BAYER4x4 = 1
  FID_BAYER8x8 = 2
  FID_CLUSTER6x6 = 3
  FID_CLUSTER8x8 = 4
  FID_CLUSTER16x16 = 5
End Enum
'End FreeImage Enums

'FreeImage Constants
Private Const JPEG_ACCURATE As Long = 2
Private Const BMP_SAVE_RLE As Long = 1
'End FreeImage Constants

'**********************************
'Window API Specific Stuff        *
'**********************************

'Windows API Declares
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, bits As Long, BitsInfo As Long, ByVal wUsage As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Any) 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function InvertRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
'Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
'End Windows API Declares

'Windows API Constants
Private Const SRCCOPY = &HCC0020
Private Const DIB_RGB_COLORS = 0
Private Const DIB_PAL_COLORS = 1
'End Windows API Constants

'Windows API Types
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
Private Type RECT
  left As Long
  top As Long
  Right As Long
  Bottom As Long
End Type
Private Type BITMAPINFOHEADER
  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 RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type
'End Windows API Types

'**********************************
'FreeImage Control Specific Stuff *
'**********************************

'Enum used for FIGetCommonDialogFilter
Public Enum cdlgType
  cdlgLoad = 0
  cdlgSave = 1
End Enum

'Enum for errors (return in many functions)
Public Enum FIMAGE_ERROR
  FIMAGE_OK = 0
  FIMAGE_ERROR_FORMAT_UNKNOWN = 1
  FIMAGE_ERROR_DRAWDIBTODC = 2
  FIMAGE_ERROR_LOAD = 3
  FIMAGE_ERROR_GETDIBITS = 4
  FIMAGE_ERROR_SAVECONVERSION = 5
  FIMAGE_ERROR_SAVE = 6
  FIMAGE_ERROR_BITBLT = 7
  FIMAGE_ERROR_INVERTRECT = 8
  FIMAGE_ERROR_SAMESIZE = 9
  FIMAGE_ERROR_LOCKPAGE = 10
  FIMAGE_ERROR_INVALIDSIZE = 11
  FIMAGE_ERROR_RESCALE = 12
  FIMAGE_ERROR_ALLOCATE = 13
  FIMAGE_ERROR_GETFREEDIBFROMPICTURE = 14
  FIMAGE_ERROR_FIBUSY = 15
  FIMAGE_ERROR_FORMAT_NOT_READABLE = 16
  FIMAGE_ERROR_NO_MEM_FILE = 17
  FIMAGE_ERROR_NO_ORIG = 18
  FIMAGE_ERROR_RUNTIME = 255
End Enum

'Default properties and storage variable

Const m_def_SaveBmpRLE = False
Dim mSaveBmpRLE As Boolean

Const m_def_SaveJpegQuality = 85
Dim mSaveJpegQuality As Long

Const m_def_SaveGifQuantizeMethod = FIQ_WUQUANT
Dim mSaveGifQuantizeMethod As FREE_IMAGE_QUANTIZE

Dim hLibrary As Long 'Stores the handle to freeimage.dll for load/freelibrary
Dim FIBusy As Byte 'Status of filter (so filters cant be run at the same time as each other)

'JMA 060221:
Const m_def_RescaleMethod = FILTER_LANCZOS3
Dim mRescaleMethod As FREE_IMAGE_FILTER
'JMA 060222:
Const m_def_SaveAsType = FIF_UNKNOWN
Dim mSaveAsType As FREE_IMAGE_FORMAT

Const m_def_OriginalRemember = False
Dim mOriginalRemember As Boolean


'==================================================================
'JMA 060220,21,22
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As String, ByVal Source As Long, ByVal Length As Long)

Dim mDIB As Long
'Dim mWidth As Long
'Dim mHeight As Long
Dim mPageCount As Integer
Dim mPageCountReaded As Boolean 'aby se načítalo jen jednou
Dim mPage As Integer
Dim mFilePath As String
Dim mFileType As FREE_IMAGE_FORMAT
Dim mFileTypeDat As FREE_IMAGE_FORMAT
Dim mFileTypeExt As FREE_IMAGE_FORMAT
Dim mError As FIMAGE_ERROR
Dim mErS As String 'hláška z objektu Err
Dim mSavedMemFile As Long

Dim mSaveOrigDIB As Boolean
Dim mOrigDIB As Long
'
'********End of Declares/Constants/Enums/Types*********



'==========================================================================
'File manipulation
'==========================
'060222 uložení formátu pro ukládání
Public Property Get SaveAsType() As FREE_IMAGE_FORMAT
  SaveAsType = mSaveAsType
End Property
Public Property Let SaveAsType(ByVal NewValue As FREE_IMAGE_FORMAT)
  mSaveAsType = NewValue
End Property

Public Property Get FilePath() As String
  FilePath = mFilePath
End Property
Public Property Let FilePath(ByVal NewValue As String)
On Error GoTo EH
  mFilePath = NewValue
  mFileTypeDat = FreeImage_GetFileType(mFilePath, 0)
  mFileTypeExt = FreeImage_GetFIFFromFilename(mFilePath)
  If mFileTypeDat = FIF_UNKNOWN Then
    mFileType = mFileTypeExt
  Else
    mFileType = mFileTypeDat
  End If
  mPageCountReaded = False
EX:
  Exit Property
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Property

Public Property Get strFileType() As FREE_IMAGE_FORMAT
On Error GoTo EH
  strFileType = strGetFileType(mFileType)
EX:
  Exit Property
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Property

Public Property Get FileType() As FREE_IMAGE_FORMAT
  FileType = mFileType
End Property

Public Property Get FileTypeExt() As FREE_IMAGE_FORMAT
  FileTypeExt = mFileTypeExt
End Property

Public Property Get FileTypeDat() As FREE_IMAGE_FORMAT
  FileTypeDat = mFileTypeDat
End Property

Public Property Get PageCount() As Integer
On Error GoTo EH
  If Not mPageCountReaded Then mPageCount = getPageCount
  PageCount = mPageCount
EX:
  Exit Property
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Property

Private Property Get FileExtensionIsBad() As Boolean
  FileExtensionIsBad = (mFileTypeDat <> mFileTypeExt)
End Property

Public Function SaveAs(ByVal FileName As String, Optional ByVal FileType As FREE_IMAGE_FORMAT = FIF_UNKNOWN) As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim tmpdib As Long
  Dim flags As Long
  Dim ret As FIMAGE_ERROR
  Dim s As String
  Dim bNewDib As Boolean
  
  If FileType = FIF_UNKNOWN Then FileType = mSaveAsType
  If FileType = FIF_UNKNOWN Then FileType = mFileType
  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  Else
    If mDIB = 0 Then
      ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
      Exit Function
    End If
    tmpdib = mDIB
    bNewDib = SavePrepareDIB(FileType, flags, tmpdib)
    If tmpdib = 0 Then 'Something went wrong during conversion
      ret = FIMAGE_ERROR_SAVECONVERSION
    Else
      If (FreeImage_Save(FileType, tmpdib, FileName, flags) = 0) Then 'Error
        ret = FIMAGE_ERROR_SAVE
      End If
      If bNewDib Then FreeImage_Unload tmpdib
    End If
  End If
EX:
  mError = ret
  SaveAs = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function MemoryClear() As FIMAGE_ERROR
'JMA 060222
'O: vyprázdní paměť uloženého souboru
On Error GoTo EH
  Dim ret As FIMAGE_ERROR
  If mSavedMemFile > 0 Then
    FreeImage_CloseMemory mSavedMemFile
    mSavedMemFile = 0
    ret = FIMAGE_OK
  Else
    ret = FIMAGE_ERROR_NO_MEM_FILE
  End If
EX:
  mError = ret
  MemoryClear = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Property Get MemoryFileSize() As Long
'JMA 060222
'O: vrátí velikost v paměti uloženého souboru
On Error GoTo EH
  Dim ret As FIMAGE_ERROR
  If mSavedMemFile > 0 Then
    MemoryFileSize = FreeImage_TellMemory(mSavedMemFile)
    ret = FIMAGE_OK
  Else
    ret = FIMAGE_ERROR_NO_MEM_FILE
  End If
EX:
  mError = ret
  Exit Property
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Property
'==========================
Public Function MemoryFileString() As String
'JMA 060222
'O: vrátí řetězec v paměti uloženého souboru
On Error GoTo EH
  Dim memBuffer As Long
  Dim memSize As Long
  Dim s As String
  Dim ret As FIMAGE_ERROR
  
  If mSavedMemFile > 0 Then
    Call FreeImage_AcquireMemory(mSavedMemFile, memBuffer, memSize)
    s = Space(memSize)
    CopyMemory s, memBuffer, memSize
    ret = FIMAGE_OK
  Else
    ret = FIMAGE_ERROR_NO_MEM_FILE
  End If
EX:
  mError = ret
  MemoryFileString = s
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function MemorySave(Optional ByVal FileType As FREE_IMAGE_FORMAT = FIF_UNKNOWN) As FIMAGE_ERROR
'JMA 060222
'O: vrátí velikost ukládaného souboru
On Error GoTo EH
  Dim tmpdib As Long
  Dim flags As Long
  Dim ret As FIMAGE_ERROR
  Dim s As String
  Dim bNewDib As Boolean
  Dim r As Long
  
  Me.MemoryClear
  If FileType = FIF_UNKNOWN Then FileType = mSaveAsType
  If FileType = FIF_UNKNOWN Then FileType = mFileType
  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  Else
    If mDIB = 0 Then
      ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
      Exit Function
    End If
    tmpdib = mDIB
    bNewDib = SavePrepareDIB(FileType, flags, tmpdib)
    If tmpdib = 0 Then 'Something went wrong during conversion
      ret = FIMAGE_ERROR_SAVECONVERSION
    Else
      mSavedMemFile = FreeImage_OpenMemory()
      If (FreeImage_SaveToMemory(FileType, tmpdib, mSavedMemFile, flags) = 0) Then  'Error
        ret = FIMAGE_ERROR_SAVE
      End If
      If bNewDib Then FreeImage_Unload tmpdib
    End If
  End If
EX:
  mError = ret
  MemorySave = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function SaveAsString(Optional ByVal FileType As FREE_IMAGE_FORMAT = FIF_UNKNOWN) As String
'JMA 060221
'O: vrátí string s obsahem ukládaného souboru
On Error GoTo EH
  Dim tmpdib As Long
  Dim flags As Long
  Dim ret As FIMAGE_ERROR
  Dim s As String
  Dim bNewDib As Boolean
  Dim r As Long
  Dim memPtr As Long
  Dim memSize As Long
  Dim memBuffer As Long

  If FileType = FIF_UNKNOWN Then FileType = mSaveAsType
  If FileType = FIF_UNKNOWN Then FileType = mFileType
  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  Else
    If mDIB = 0 Then
      ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
      Exit Function
    End If
    tmpdib = mDIB
    bNewDib = SavePrepareDIB(FileType, flags, tmpdib)
    If tmpdib = 0 Then 'Something went wrong during conversion
      ret = FIMAGE_ERROR_SAVECONVERSION
    Else
      memPtr = FreeImage_OpenMemory()
      If (FreeImage_SaveToMemory(FileType, tmpdib, memPtr, flags) = 0) Then  'Error
        ret = FIMAGE_ERROR_SAVE
      Else
        Call FreeImage_AcquireMemory(memPtr, memBuffer, memSize)
        s = Space(memSize)
        CopyMemory s, memBuffer, memSize
      End If
      FreeImage_CloseMemory memPtr
      If bNewDib Then FreeImage_Unload tmpdib
    End If
  End If
EX:
  mError = ret
  SaveAsString = s
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Private Function SavePrepareDIB(ByVal fif As FREE_IMAGE_FORMAT, flags As Long, DIB As Long) As Boolean
'JMA 060221
'O: true, když se vrací kopie dib => musí se po Save vyprázdnit
  Dim tmpdib As Long
  Dim tmpdib2 As Long
  If fif = FIF_JPEG Then 'Do conversions for filetypes that have limitations and prep flags
    Select Case FreeImage_GetBPP(mDIB)
    Case 8, 24
    Case Else
      tmpdib = FreeImage_ConvertTo24Bits(DIB)
      DIB = tmpdib
      SavePrepareDIB = True
    End Select
    flags = mSaveJpegQuality
  ElseIf fif = FIF_GIF Then
    tmpdib = FreeImage_ConvertTo24Bits(DIB)
    tmpdib2 = FreeImage_ColorQuantize(tmpdib, mSaveGifQuantizeMethod)
    FreeImage_Unload tmpdib
    DIB = tmpdib2
    SavePrepareDIB = True
  ElseIf (fif = FIF_BMP) And (mSaveBmpRLE = True) Then      'This code removed due to bug
  End If
End Function
'==========================
Public Function Load(Optional ByVal FileName As String = "") As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim flags As Long
  Dim ret As FIMAGE_ERROR

  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
    Exit Function
  End If
  
  If Len(FileName) > 0 Then Me.FilePath = FileName 'Get File Format
    
  If mFileType = FIF_UNKNOWN Then 'Exit If Unknown
    ret = FIMAGE_ERROR_FORMAT_UNKNOWN
  ElseIf FreeImage_FIFSupportsReading(mFileType) = 0 Then
    ret = FIMAGE_ERROR_FORMAT_NOT_READABLE
  Else
    If mFileType = FIF_JPEG Then flags = JPEG_ACCURATE 'Always load jpegs accurately
    mDIB = FreeImage_Load(mFileType, mFilePath, flags) 'Load Image
    If mDIB = 0 Then  'Problem During Load
      ret = FIMAGE_ERROR_LOAD       'Exit Function
    Else
'      mWidth = FreeImage_GetWidth(mDIB)
'      mHeight = FreeImage_GetHeight(mDIB)
'      mOrigDIB = mDIB
    End If
  End If
EX:
  mError = ret
  Load = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Private Function getPageCount() As Integer
'upr.JMA 060220
  Dim multidib As Long

  If mFileType = FIF_UNKNOWN Then 'Exit If Unknown
  ElseIf mFileType = FIF_TIFF Then
    multidib = FreeImage_OpenMultiBitmap(mFileType, mFilePath, 0, 1, 1)
    getPageCount = FreeImage_GetPageCount(multidib)
    FreeImage_CloseMultiBitmap multidib, 0
    Exit Function
  Else
    getPageCount = 1
  End If
End Function
'==========================
Public Function LoadPage(ByVal Page As Integer) As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim multidib As Long
  Dim flags As Long
  Dim ret As FIMAGE_ERROR
  
  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mFileType = FIF_UNKNOWN Then 'Exit If Unknown
    ret = FIMAGE_ERROR_FORMAT_UNKNOWN
  ElseIf mFileType = FIF_TIFF Then
    'This is start of future code for multipage tif
    multidib = FreeImage_OpenMultiBitmap(mFileType, FilePath, 0, 1, 1)
    mDIB = FreeImage_LockPage(multidib, Page - 1)
    If mDIB = 0 Then
      ret = FIMAGE_ERROR_LOCKPAGE
    Else
'      mWidth = FreeImage_GetWidth(dib)
'      mHeight = FreeImage_GetHeight(dib)
      FreeImage_UnlockPage multidib, Page - 1, 0
      mPage = Page
    End If
    FreeImage_CloseMultiBitmap multidib, 0
  End If
EX:
  mError = ret
  LoadPage = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function

'==========================================================
'Class
'===============
Private Sub Class_Initialize()
On Error GoTo EH
  hLibrary = LoadLibrary(Bs(CurrentProject.Path) & "FreeImage.dll")
  If hLibrary = 0 Then
    MsgBox "Failed to load FreeImage.dll", vbCritical, "DLL Load Error"
    Exit Sub
  End If
'  Dim tmpVersion As String
'  tmpVersion = FIGetVersion
'  If FIGetVersion <> "3.6.1" Then MsgBox ("Incorrect FreeImage.dll Version" + vbNewLine + "Should be 3.6.1" + vbNewLine + "Yours is " + tmpVersion), vbOKOnly, "DLL Error"
  mSaveBmpRLE = m_def_SaveBmpRLE
  mSaveJpegQuality = m_def_SaveJpegQuality
  mSaveGifQuantizeMethod = m_def_SaveGifQuantizeMethod
  mRescaleMethod = m_def_RescaleMethod
  mSaveAsType = m_def_SaveAsType
  mOriginalRemember = m_def_OriginalRemember
  mError = FIMAGE_OK
EX:
  Exit Sub
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Sub

'******************************************************
Private Sub Class_Terminate()
On Error GoTo EH
  FreeImage_Unload mDIB
  If mOriginalRemember And mDIB <> mOrigDIB Then FreeImage_Unload mOrigDIB
  FreeLibrary hLibrary
  If mSavedMemFile > 0 Then FreeImage_CloseMemory mSavedMemFile
EX:
  Exit Sub
EH:
  MsgBox err.Description
  Resume EX
End Sub

'==========================================================
'Save modes
'===============
Public Property Get SaveBmpRLE() As Boolean
  SaveBmpRLE = mSaveBmpRLE
End Property
Public Property Let SaveBmpRLE(ByVal NewValue As Boolean)
  mSaveBmpRLE = NewValue
End Property
'===============
Public Property Get SaveJpegQuality() As Long
  SaveJpegQuality = mSaveJpegQuality
End Property
Public Property Let SaveJpegQuality(ByVal NewValue As Long)
  mSaveJpegQuality = NewValue
  If mSaveJpegQuality > 100 Then mSaveJpegQuality = 100
  If mSaveJpegQuality < 1 Then mSaveJpegQuality = 1
End Property
'===============
Public Property Get SaveGifQuantizeMethod() As FREE_IMAGE_QUANTIZE
  SaveGifQuantizeMethod = mSaveGifQuantizeMethod
End Property
Public Property Let SaveGifQuantizeMethod(ByVal NewValue As FREE_IMAGE_QUANTIZE)
  mSaveGifQuantizeMethod = NewValue
End Property
'===============
'JMA 060221:
Public Property Get RescaleMethod() As FREE_IMAGE_FILTER
  RescaleMethod = mRescaleMethod
End Property
Public Property Let RescaleMethod(ByVal NewValue As FREE_IMAGE_FILTER)
  mRescaleMethod = NewValue
End Property
'===================================================================
'Working with original DIB
'==============================
'JMA 060222:
'==============================
Public Property Get OriginalRemember() As Boolean
  OriginalRemember = mOriginalRemember
End Property
Public Property Let OriginalRemember(ByVal NewValue As Boolean)
  If (mDIB = 0 And mOrigDIB = 0) Then 'při startu
    mOriginalRemember = NewValue
  ElseIf mDIB = mOrigDIB Then 'pokud se nic s obrázkem nedělalo
    mOriginalRemember = NewValue
  Else
  End If
End Property

Public Function Original() As FIMAGE_ERROR
On Error GoTo EH
  Dim ret As FIMAGE_ERROR
  'nahradí současný mdib originálem
  If Not mOriginalRemember Then
    ret = FIMAGE_ERROR_NO_ORIG
  ElseIf mOrigDIB = 0 Then
    ret = FIMAGE_ERROR_NO_ORIG
  ElseIf mDIB <> mOrigDIB Then
    FreeImage_Unload mDIB
    mDIB = mOrigDIB
    ret = FIMAGE_OK
  End If
EX:
  Original = ret
  mError = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'===================================================================
'Type (file format) functions
'==============================
Public Function strCommonDialogFilter(ByVal Method As cdlgType) As String
'upr. JMA 060220
On Error GoTo EH
  Dim i As Integer
  Dim sFilter As String
  Dim sAll As String
  Dim sE As String
  Dim sD As String
  
  For i = 0 To FreeImage_GetFIFCount - 1
    'Load has All Known and All Files included
    sE = strTypeExtensionFilter(i)
    sD = strTypeDescription(i)
    Select Case Method
    Case cdlgLoad
      If FreeImage_FIFSupportsReading(i) Then
        sFilter = sFilter + sD + "(" + sE + ")|" + sE + "|"
        sAll = sAll + sE + ";"
      End If
    Case cdlgSave
      If FreeImage_FIFSupportsWriting(i) Then
        sFilter = sFilter + sD + "(" + sE + ")|" + sE + "|"
      End If
    End Select
  Next i
  'Add Extra Stuff if loading
  If sAll <> "" Then sAll = "All Known Formats|" + sAll + "|All Files (*.*)|*.*|"

  'Return sFilter as string
  strCommonDialogFilter = sAll + left(sFilter, Len(sFilter) - 1) + ""
  mError = FIMAGE_OK
EX:
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'==============================
Public Function TypeExtensionList(ByVal fif As FREE_IMAGE_FORMAT) As String 'Integer
'JMA 060221
On Error GoTo EH
  TypeExtensionList = strTypeExtensionList(fif)
  mError = FIMAGE_OK
EX:
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'==============================
Public Function TypeDescription(ByVal fif As FREE_IMAGE_FORMAT) As String 'Integer
'JMA 060221
On Error GoTo EH
  TypeDescription = strTypeDescription(fif)
  mError = FIMAGE_OK
EX:
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function

'==============================
Private Function strTypeExtensionList(ByVal fif As FREE_IMAGE_FORMAT) As String 'Integer
'upr. JMA 060220
  Dim FreeInfoPtr As Long
  Dim msg As String
  
  FreeInfoPtr = FreeImage_GetFIFExtensionList(fif) 'FREE_IMAGE_FORMAT
  msg = Space(lstrlen(FreeInfoPtr))
  lstrcpy msg, FreeInfoPtr
  strTypeExtensionList = msg
  
End Function
'==============================
Private Function strTypeExtensionFilter(ByVal sExtensions As String) As String 'Integer
'JMA 060220
  strTypeExtensionFilter = "*." & Replace(sExtensions, ",", ";*.")
End Function
'==============================
Private Function strTypeDescription(ByVal fif As FREE_IMAGE_FORMAT) ' As Integer
'upr. JMA 060220
  Dim FreeInfoPtr As Long
  Dim msg As String
  
  FreeInfoPtr = FreeImage_GetFIFDescription(fif)
  msg = Space(lstrlen(FreeInfoPtr))
  lstrcpy msg, FreeInfoPtr
  strTypeDescription = msg
End Function
'==============================
Private Function strGetFileType(fif As FREE_IMAGE_FORMAT) As String
  strGetFileType = Split(strTypeExtensionList(fif), ",")(0)
'JMA 060220
'  Dim ret As Long
'  Select Case mFileType
'  Case -1: ret = "" 'UNKNOWN
'  Case 0: ret = "BMP"
'  Case 1: ret = "ICO"
'  Case 2: ret = "JPG" 'JPEG
'  Case 3: ret = "JNG"
'  Case 4: ret = "KOALA"
'  Case 5: ret = "LBM" 'nebo  "IFF"
'  Case 6: ret = "MNG"
'  Case 7: ret = "PBM"
'  Case 8: ret = "PBMRAW"
'  Case 9: ret = "PCD"
'  Case 10: ret = "PCX"
'  Case 11: ret = "PGM"
'  Case 12: ret = "PGMRAW"
'  Case 13: ret = "PNG"
'  Case 14: ret = "PPM"
'  Case 15: ret = "PPMRAW"
'  Case 16: ret = "RAS"
'  Case 17: ret = "TGA" 'TARGA
'  Case 18: ret = "TIF" 'TIFF
'  Case 19: ret = "WBMP"
'  Case 20: ret = "PSD"
'  Case 21: ret = "CUT"
'  Case 22: ret = "XBM"
'  Case 23: ret = "XPM"
'  Case 24: ret = "DDS"
'  Case 25: ret = "GIF"
'  Case Else: ret = ""
'  End Select
'  strGetFileType = ret
End Function

'==========================================================================
'Image manipulation - extended
'==========================
Public Function DimensionsToRectangle(ByVal w As Long, ByVal h As Long, ByVal maxW As Long, ByVal maxH As Long)
'JMA 060218
'přepočítá rozměry, aby se vešly do obdélníka maxw x maxh, menší ponechá
'O: vrátí nové rozměry v poli w,h
On Error GoTo EH
  If (w > maxW Or h > maxH) Then
    If (w > maxW) Then
      h = (maxW / w) * h
      w = maxW
    End If
    If (h > maxH) Then
      w = (maxH / h) * w
      h = maxH
    End If
  End If
  DimensionsToRectangle = Array(Round(w), Round(h))
  
  mError = FIMAGE_OK
EX:
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'==========================
Public Function DimensionsToSquare(ByVal w As Long, ByVal h As Long, ByVal sq As Long)
'JMA 060218
'přepočítá rozměry, aby se vešly do čtverce o hraně $sq, menší ponechá
'O: vrátí nové rozměry v poli w,h
On Error GoTo EH
  If (w > sq Or h > sq) Then
    If (w > h) Then
      h = (sq / w) * h
      w = sq
    Else
      w = (sq / h) * w
      h = sq
    End If
  End If
  DimensionsToSquare = Array(Round(w), Round(h))
  
  mError = FIMAGE_OK
EX:
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'==========================
Public Function Resample(ByVal NewWidth As Long, ByVal NewHeight As Long) As FIMAGE_ERROR
  Dim w As Long, h As Long
  Dim a
  Dim ret As FIMAGE_ERROR
  
  a = DimensionsToRectangle(Me.Width, Me.Height, NewWidth, NewHeight) 'volání ošetřené public fce
  If mError = FIMAGE_OK Then
    w = a(0): h = a(1)
    ret = Rescale(w, h)
  End If
EX:
  mError = ret
  Resample = ret
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'==========================
Public Function ResampleToSquare(ByVal Square As Long) As FIMAGE_ERROR
  Dim w As Long, h As Long
  Dim a
  Dim ret As FIMAGE_ERROR
  
  a = DimensionsToSquare(Me.Width, Me.Height, Square)
  If mError = FIMAGE_OK Then
    w = a(0): h = a(1)
    ret = Rescale(w, h)
  End If
EX:
  mError = ret
  ResampleToSquare = ret
  Exit Function
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function
'
'
''******************************************************
'Public Function FIGetThumbnail(FileName As String, MaxWidth As Long, MaxHeight As Long, Method As FREE_IMAGE_FILTER, HasBackground As Boolean) As FIMAGE_ERROR
'If FIBusy = 1 Then
'  FIGetThumbnail = FIMAGE_ERROR_FIBUSY
'  Exit Function
'End If
'
'  Dim fif As FREE_IMAGE_FORMAT
'  Dim dib As Long
'  Dim DIBWidth As Long
'  Dim DIBHeight As Long
'  Dim NewWidth As Long
'  Dim NewHeight As Long
'  Dim flags As Long
'  Dim retval As Long
'  Dim ScaleFactor As Double
'  Dim tmpdib As Long
'
'    'Get File Format
'    fif = FreeImage_GetFileType(FileName, 0)
'    If fif = FIF_UNKNOWN Then
'      fif = FreeImage_GetFIFFromFilename(FileName)
'    End If
'
'    'Exit If Unknown
'    If fif = FIF_UNKNOWN Then
'      FIGetThumbnail = FIMAGE_ERROR_FORMAT_UNKNOWN
'      Exit Function
'    End If
'
'    'Load Image
'    If fif = FIF_JPEG Then flags = JPEG_ACCURATE
'    dib = FreeImage_Load(fif, FileName, flags)
'    If dib = 0 Then
'      'Problem During Load
'      FIGetThumbnail = FIMAGE_ERROR_LOAD
'      Exit Function
'    End If
'
'    'Get Size
'    DIBWidth = FreeImage_GetWidth(dib)
'    DIBHeight = FreeImage_GetHeight(dib)
'
'    'Get Scaling Details
'
'    If DIBWidth > DIBHeight Then
'      ScaleFactor = DIBWidth / DIBHeight
'
'      NewWidth = MaxWidth
'      NewHeight = NewWidth / ScaleFactor
'
'      If NewHeight > MaxHeight Then
'        NewHeight = MaxHeight
'        NewWidth = NewHeight * ScaleFactor
'      End If
'    End If
'
'    If DIBWidth < DIBHeight Then
'      ScaleFactor = DIBHeight / DIBWidth
'
'      NewHeight = MaxHeight
'      NewWidth = NewHeight / ScaleFactor
'
'      If NewWidth > MaxWidth Then
'        NewWidth = MaxWidth
'        NewHeight = NewWidth * ScaleFactor
'      End If
'    End If
'
'    If DIBWidth = DIBHeight Then
'      If MaxWidth > MaxHeight Then
'        NewWidth = MaxHeight
'        NewHeight = MaxHeight
'      End If
'      If MaxWidth < MaxHeight Then
'        NewWidth = MaxWidth
'        NewHeight = MaxWidth
'      End If
'      If MaxWidth = MaxHeight Then
'        NewWidth = MaxWidth
'        NewHeight = MaxHeight
'      End If
'    End If
'
'    'Cant Resize images<8bit so convert
'    If FreeImage_GetBPP(dib) < 8 Then
'      tmpdib = FreeImage_ConvertTo24Bits(dib)
'      FreeImage_Unload dib
'      dib = tmpdib
'    End If
'
'    tmpdib = FreeImage_Rescale(dib, NewWidth, NewHeight, Method)
'    FreeImage_Unload dib
'    dib = tmpdib
'
'    If HasBackground = True Then
'      If AutoSize Then
'        UserControl.width = MaxWidth * Screen.TwipsPerPixelX
'        UserControl.height = MaxHeight * Screen.TwipsPerPixelY
'      End If
'    Else
'      If AutoSize Then
'        UserControl.width = NewWidth * Screen.TwipsPerPixelX
'        UserControl.height = NewHeight * Screen.TwipsPerPixelY
'      End If
'    End If
'    'The next line seems to be necessary to make sure the control
'    'knows its new size, and also clears to the backgorund color
'    UserControl.Cls
'
'    'Draw To DC
'    If HasBackground = True Then
'      retval = DrawDibToDC(dib, UserControl.hDC, (MaxWidth / 2) - (NewWidth / 2), (MaxHeight / 2) - (NewHeight / 2), NewWidth, NewHeight)
'    Else
'      retval = DrawDibToDC(dib, UserControl.hDC, 0, 0, NewWidth, NewHeight)
'    End If
'
'    If retval = 0 Then FIGetThumbnail = FIMAGE_ERROR_DRAWDIBTODC
'
'    'Unload
'    FreeImage_Unload dib
'End Function


'==========================================================================
'Image manipulation - basic
'==========================
Public Function Rescale(ByVal NewWidth As Long, ByVal NewHeight As Long) As FIMAGE_ERROR ', ByVal Method As FREE_IMAGE_FILTER
'upr. JMA 060220
On Error GoTo EH
  Dim tmpdib As Long
  Dim ret As FIMAGE_ERROR

  If NewWidth = 0 Or NewHeight = 0 Then
    ret = FIMAGE_ERROR_INVALIDSIZE
  ElseIf FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf (NewWidth = Me.Width) And (NewHeight = Me.Height) Then 'Same Size Do Nothing
    ret = FIMAGE_ERROR_SAMESIZE
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else 'rescale to tmpdib and unload old
    'Cant Resize images<8bit so convert
    If FreeImage_GetBPP(mDIB) < 8 Then
      tmpdib = FreeImage_ConvertTo24Bits(mDIB)
      mDIB = tmpdib
      FreeImage_Unload mDIB
    End If
    tmpdib = FreeImage_Rescale(mDIB, NewWidth, NewHeight, mRescaleMethod)
    If mDIB = 0 Then 'Error Resizing
      ret = FIMAGE_ERROR_RESCALE
    Else
      If Not (mOriginalRemember And mDIB = mOrigDIB) Then FreeImage_Unload mDIB
      mDIB = tmpdib
    End If
  End If
EX:
  mError = ret
  Rescale = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function Dither(ByVal Method As FREE_IMAGE_DITHER) As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim tmpdib As Long
  Dim ret As FIMAGE_ERROR

  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else
    tmpdib = FreeImage_Dither(mDIB, Method)
    FreeImage_Unload mDIB
    mDIB = tmpdib
  End If
EX:
  mError = ret
  Dither = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function FlipHorizontal() As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim ret As FIMAGE_ERROR

  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else
    FreeImage_FlipHorizontal mDIB
'    retval = DrawDibToDC(mdib, UserControl.hDC, 0, 0, mwidth, mheight)
  End If
EX:
  mError = ret
  FlipHorizontal = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function FlipVertical() As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim ret As FIMAGE_ERROR
  
  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else
    FreeImage_FlipVertical mDIB
'  retval = DrawDibToDC(mdib, UserControl.hDC, 0, 0, mwidth, mheight)
  End If
EX:
  mError = ret
  FlipVertical = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function RotateClassic(ByVal Angle As Double) As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim tmpdib As Long
  Dim ret As FIMAGE_ERROR

  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else
    tmpdib = FreeImage_RotateClassic(mDIB, Angle)
    FreeImage_Unload mDIB
    mDIB = tmpdib
'    mWidth = FreeImage_GetWidth(mDIB)
'    mHeight = FreeImage_GetHeight(mDIB)
  End If
EX:
  mError = ret
  RotateClassic = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function RotateEx(ByVal Angle As Double, ByVal Mask As Boolean) As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim tmpdib As Long
  Dim ret As FIMAGE_ERROR
'  Dim xOrig As Long
'  Dim yOrig As Long

  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else
'    xOrig = FreeImage_GetWidth(mdib) / 2
'    yOrig = FreeImage_GetHeight(mdib) / 2
'    tmpdib = FreeImage_RotateEx(mdib, Angle, 0, 0, xOrig, yOrig, CLng(Not Mask))
    tmpdib = FreeImage_RotateEx(mDIB, Angle, 0, 0, Me.Width \ 2, Me.Height \ 2, CLng(Not Mask))
    FreeImage_Unload mDIB
    mDIB = tmpdib
'    mWidth = FreeImage_GetWidth(mDIB)
'    mHeight = FreeImage_GetHeight(mDIB)
  End If
EX:
  mError = ret
  RotateEx = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  Resume EX
End Function
'==========================
Public Function GreyScale() As FIMAGE_ERROR
'upr. JMA 060220
On Error GoTo EH
  Dim tmpdib As Long
  Dim ret As FIMAGE_ERROR
  
  If FIBusy = 1 Then
    ret = FIMAGE_ERROR_FIBUSY
  ElseIf mDIB = 0 Then 'Problem Getting A DIB
    ret = FIMAGE_ERROR_GETFREEDIBFROMPICTURE
  Else
'    tmpdib = FreeImage_ConvertTo8Bits(mDIB)
    tmpdib = FreeImage_ConvertToGreyscale(mDIB)
    If Not (mOriginalRemember And mDIB = mOrigDIB) Then FreeImage_Unload mDIB
    mDIB = tmpdib
  End If
EX:
  mError = ret
  GreyScale = ret
  Exit Function
EH:
  ret = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Function

'=========================================================
'Image properties
'==========================
'Public Property Get DIB() As Long 'Nebezpečné! Jen pro externí operace
'  DIB = mDIB
'End Property
'==========================
Public Property Get Height() As Long
    Height = FreeImage_GetHeight(mDIB)
End Property
'==========================
Public Property Get Width() As Long
    Width = FreeImage_GetWidth(mDIB)
End Property

'=========================================================
'Error handling
'==========================
Public Property Get ErrorNumber() As FIMAGE_ERROR
'JMA 060220
  ErrorNumber = mError
End Property
'==========================
Public Property Get Error() As String
'JMA 060220
  Error = strErr(mError)
End Property
'==========================
Public Function strErr(ByVal errconst As FIMAGE_ERROR) As String
'upr. JMA 060220
  Dim ret As String
  Select Case errconst
  Case FIMAGE_OK:      ret = "There was no error."
  Case FIMAGE_ERROR_FORMAT_UNKNOWN:      ret = "Unknown image format"
  Case FIMAGE_ERROR_DRAWDIBTODC:      ret = "There was an error drawing to screen (DrawDibToDC)"
  Case FIMAGE_ERROR_LOAD:      ret = "Error loading image (FreeImage_Load)"
  Case FIMAGE_ERROR_GETDIBITS:      ret = "There was an error getting the image (GetDIBits)"
  Case FIMAGE_ERROR_SAVECONVERSION:      ret = "Error while converting before save."
  Case FIMAGE_ERROR_SAVE:      ret = "Error saving image"
  Case FIMAGE_ERROR_BITBLT:      ret = "There was an error copying the image (BitBlt)"
  Case FIMAGE_ERROR_INVERTRECT:      ret = "Unable to invert image (InvertRect)"
  Case FIMAGE_ERROR_SAMESIZE:      ret = "New size is identical to old size."
  Case FIMAGE_ERROR_LOCKPAGE:      ret = "Unable to lock page."
  Case FIMAGE_ERROR_INVALIDSIZE:      ret = "An invalid size was passed."
  Case FIMAGE_ERROR_RESCALE:      ret = "A problem occurred while rescaling."
  Case FIMAGE_ERROR_ALLOCATE:      ret = "Unable to allocate a FreeImage DIB."
  Case FIMAGE_ERROR_GETFREEDIBFROMPICTURE:      ret = "Unable to retrieve a FreeImage DIB from the controls image."
  Case FIMAGE_ERROR_FIBUSY:      ret = "Please wait, an operation is still running."
  Case FIMAGE_ERROR_FORMAT_NOT_READABLE:      ret = "Format reading not supported."
  Case FIMAGE_ERROR_NO_MEM_FILE:      ret = "No file saved in memory."
  Case FIMAGE_ERROR_RUNTIME:      ret = "Runtime error: " & mErS
  Case FIMAGE_ERROR_NO_ORIG:      ret = "Original DIB not set."
  Case Else:       ret = "Unknown Error: Code " + Trim(str(errconst))
  End Select
  strErr = ret
End Function

'=========================================================
'Informations
'==========================
Public Property Get InfoCopyrightMessage() As String
'upr. JMA 060220,21
On Error GoTo EH
  Dim FreeInfoPtr As Long
  Dim msg As String
  
  FreeInfoPtr = FreeImage_GetCopyrightMessage
  msg = Space(lstrlen(FreeInfoPtr))
  lstrcpy msg, FreeInfoPtr
  InfoCopyrightMessage = msg
  
  mError = FIMAGE_OK
EX:
  Exit Property
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Property
'==========================
Public Property Get InfoVersion() As String
'upr. JMA 060220,21
On Error GoTo EH
  Dim FreeInfoPtr As Long
  Dim msg As String
  
  FreeInfoPtr = FreeImage_GetVersion
  msg = Space(lstrlen(FreeInfoPtr))
  lstrcpy msg, FreeInfoPtr
  InfoVersion = msg
  mError = FIMAGE_OK
EX:
  Exit Property
EH:
  mError = FIMAGE_ERROR_RUNTIME
  mErS = err.Number & ": " & err.Description
  Resume EX
End Property

Abych poznal, že jsou to moje knihovny a konstanty, a ne mikrosoftí, a aby se mi dobře hledaly, píšu si důsledně před názvy své "jma*", tak se nedivte.

Použijete-li kus mého kódu, je slušnost mezi programátory uvést v kódu zdroj: www.tuzka.cz/jma

LoadLibrary

Ještě něco: velmi jsem přivítal následující postup: místo registrování libovolné knihovny do systému:
dám soubor knihovny jen do složky s aplikací a použiju WinAPI funkce LoadLibrary a FreeLibrary.
Od té doby to s úspěchem používám i na další DLL knihovny.

-jma-

Doporučuji
Exit 316
Letní tábor Doubravka 2009 s Beberkou
Exit 316
Nový TV pořad od září 2006!
Pro děti - zvědavé otázky se Zvědavou tužkou
KROKY - Časopis pro děti
křesťanská díla, CF - nejen databáze křesťanských písní
Komerce atd.
Podpořte snahu proti zavedení SW patentů!!!
profi webhosting Gigaweb
Nabídka SW a služeb
Kniha pošty
KOALA
Tvorba www
Umístění stránek
Chcete internetový obchod?