' Small implementation of the FreeImage library.
' This file contains only calls for loading a by FreeImage supported image.
' The library is loaded on demand.
' Download FreeImage at: <http://www.6ixsoft.com> 

%FIF_UNKNOWN = -1
%FIF_BMP = 0
%FIF_ICO = 1
%FIF_JPEG = 2
%FIF_JNG = 3
%FIF_KOALA = 4
%FIF_LBM = 5
%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 'Compression: PackBits, uncompressed, NO LZW
%FIF_WBMP = 19
%FIF_PSD = 20
%FIF_CUT = 21
%FIF_IFF = %FIF_LBM

'====================================================
' Internal use
'====================================================

Type FreeImage_Proc

pGetVersion As Dword
pGetCopyrightMessage As Dword
pGetFileType As Dword
pLoad As Dword
pFree As Dword
pGetInfoHeader As Dword
pGetBits As Dword
pGetInfo As Dword

End Type

Type FreeImage_Params

hLib As Long
DProcs As FreeImage_Proc

End Type

Global FreeImage_Param As FreeImage_Params

Declare Function FreeImg_GetVersion() As Dword
Declare Function FreeImg_GetCopyrightMessage() As Dword
Declare Function FreeImg_GetFileType( szFileName As Asciiz, ByVal nSize As Long ) As Long
Declare Function FreeImg_Load( ByVal fif As Long, szFileName As Asciiz, ByVal nflags As Long ) As Long
Declare Function FreeImg_Free( ByVal hfidib As Long ) As Long
Declare Function FreeImg_GetInfoHeader( ByVal hfidib As Long ) As Long
Declare Function FreeImg_GetBits( ByVal hfidib As Long ) As Long
Declare Function FreeImg_GetInfo( ByVal hfidib As Long ) As Long

'====================================================
' Public use
'====================================================

' This call loads the FreeImage library, an optional library name may be set.
' All other procedures will call this procedure anyway.
' The lib is loaded only once.
Function FreeImage_LoadLibrary( ByVal sOptLibName As String ) As Long

Dim dp As FreeImage_Params

If FreeImage_Param.hLib Then
Function = 1
Exit Function
End If

sOptLibName = Trim$( sOptLibName )

If sOptLibName > "" Then
FreeImage_Param.hLib = LoadLibrary( ByVal StrPtr( sOptLibName ) )
Else
FreeImage_Param.hLib = LoadLibrary( "FreeImage.DLL" )
End If

Select Case FreeImage_Param.hLib
Case 0 To 32
FreeImage_Param.hLib = 0
Exit Function
End Select

FreeImage_Param.DProcs.pGetVersion = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_GetVersion@0" )
FreeImage_Param.DProcs.pGetCopyrightMessage = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_GetCopyrightMessage@0" )
FreeImage_Param.DProcs.pGetFileType = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_GetFileType@8" )
FreeImage_Param.DProcs.pLoad = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_Load@12" )
FreeImage_Param.DProcs.pFree = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_Free@4" )
FreeImage_Param.DProcs.pGetInfoHeader = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_GetInfoHeader@4" )
FreeImage_Param.DProcs.pGetBits = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_GetBits@4" )
FreeImage_Param.DProcs.pGetInfo = GetProcAddress( FreeImage_Param.hLib, "_FreeImage_GetInfo@4" )

' Are all calls available IN the DLL?
If Instr( Peek$( VarPtr( FreeImage_Param.DProcs ), Len( FreeImage_Proc ) ), Mkl$( 0 ) ) Then

FreeLibrary FreeImage_Param.hLib
FreeImage_Param = dp

End If

Function = IsTrue( FreeImage_Param.hLib )

End Function

' You should free the library on application exit.
Function FreeImage_FreeLibrary() As Long

Dim dp As FreeImage_Params

If FreeImage_Param.hLib = 0 Then Exit Function

FreeLibrary FreeImage_Param.hLib

FreeImage_Param = dp

Function = 1

End Function

'====================================================
' FreeImage API
'====================================================
Function FreeImage_GetVersion() As String

Dim pszText As Asciiz Ptr

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pGetVersion Using FreeImg_GetVersion() To pszText
If pszText = 0 Then Exit Function

Function = @pszText

End Function

Function FreeImage_GetCopyrightMessage() As String

Dim pszText As Asciiz Ptr

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pGetCopyrightMessage Using FreeImg_GetCopyrightMessage() To pszText
If pszText = 0 Then Exit Function

Function = @pszText

End Function

Function FreeImage_GetFileType( ByVal sFileName As String, ByVal nSize As Long ) As Long

Dim nResult As Long

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pGetFileType Using FreeImg_GetFileType( ByVal StrPtr( sFileName ), nSize ) To nResult

Function = nResult

End Function

Function FreeImage_Load( ByVal fif As Long, ByVal sFileName As String, ByVal nflags As Long ) As Long

Dim nResult As Long

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pLoad Using FreeImg_Load( fif, ByVal StrPtr( sFileName ), nFlags ) To nResult

Function = nResult

End Function

Function FreeImage_Free( ByVal hfidib As Long ) As Long

Dim nResult As Long

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pFree Using FreeImg_Free( hfidib ) To nResult

Function = nResult

End Function

Function FreeImage_GetInfoHeader( ByVal hfidib As Long ) As Long

Dim nResult As Long

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pGetInfoHeader Using FreeImg_GetInfoHeader( hfidib ) To nResult

Function = nResult

End Function

Function FreeImage_GetBits( ByVal hfidib As Long ) As Long

Dim nResult As Long

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pGetBits Using FreeImg_GetBits( hfidib ) To nResult

Function = nResult

End Function

Function FreeImage_GetInfo( ByVal hfidib As Long ) As Long

Dim nResult As Long

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

Call Dword FreeImage_Param.DProcs.pGetInfo Using FreeImg_GetInfo( hfidib ) To nResult

Function = nResult

End Function

' Wrapper to load image and create a Windows bitmap handle (DIB)
' You should use DeleteObject() API to destroy this handle.
' hDC might be 0 to use the screen device.
Function FreeImage_LoadDIB( ByVal hDC As Long, ByVal sFileName As String ) As Long

Dim hUsehDC As Long
Dim nFileType As Long
Dim hDIB As Long
Dim hfidib As Long

sFileName = Trim$( sFileName )
If sFileName = "" Then Exit Function

If FreeImage_LoadLibrary( "" ) = 0 Then Exit Function

nFileType = FreeImage_GetFileType( sFileName, 0 )
hfidib = FreeImage_Load( nFileType, sFileName, 0 )

If hfidib Then

hUsehDC = hDC
If hDC = 0 Then hUsehDC = GetDC( %HWND_DESKTOP )

hDIB = CreateDIBitmap( _
hUsehDC _
, ByVal FreeImage_GetInfoHeader( hfidib ) _
, %CBM_INIT _
, ByVal FreeImage_GetBits( hfidib ) _
, ByVal FreeImage_GetInfo( hfidib ) _
, %DIB_RGB_COLORS _
)

If hDC = 0 Then ReleaseDC %HWND_DESKTOP, hUsehDC

End If

If hfidib Then FreeImage_Free hfidib

Function = hDIB

End Function