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