Needed code to produce and store thumbnails in a database found my old code but not complete.
This is a programme that asks for a folder then searches that folder for all files with the .jpg extension.
It creates a thumbnail database in the selected folder.
It then creates thumbnails for all files found and stores then in a database with an Ident and the original filename. The Ident in this case is just a count of the images processed.
You can specify the size of the thumbnail e.g. 150 will create thumbnails 150 X 150.
The aspect ratio of the original image is kept when resizing so the thumbs look correct.
The second programme is just a quick one to check the thumbs have been created OK.
First Create Thumbs
Code: Select all
EnableExplicit
UseSQLiteDatabase()
UsePNGImageDecoder()
UseJPEGImageDecoder()
UseGIFImageDecoder()
Global frmThumbs.i,btnChooseFolder, txtStatus, prgStatus, btnDone
Global FolderToUse.s,TotalImages.i,ImageDB.i
;Determines size of thumbnail. Larger size lrger database!
Global ThumbSize.i = 150
Global Count.i
Macro FileExists(filename)
Bool(FileSize(fileName) > -1)
EndMacro
Procedure.i CreateDB()
If CreateFile(0, FolderToUse + "ImageThumbs.db")
CloseFile(0)
ImageDB = OpenDatabase(#PB_Any, FolderToUse + "ImageThumbs.db", "", "")
If ImageDB <> 0
DatabaseUpdate(ImageDB, "CREATE TABLE [Images] (Ident INTEGER,Filename TEXT,[Image] BLOB NULL);")
CloseDatabase(ImageDB)
Else
ProcedureReturn #False
EndIf
Else
ProcedureReturn #False
EndIf
ProcedureReturn #True
EndProcedure
Procedure SearchDirectory(dir$, pattern$, List dList.s(), level.l = 0)
Protected eName$
NewList Dirs.s()
Static FileCount.i
If (level = 0)
ClearList(dList())
EndIf
If Right(dir$, 1) <> "/"
dir$ + "/"
EndIf
If ExamineDirectory(0, dir$, "")
While NextDirectoryEntry(0)
If DirectoryEntryType(0) = #PB_DirectoryEntry_Directory
eName$ = DirectoryEntryName(0)
If (eName$ <> ".") And (eName$ <> "..")
AddElement(Dirs())
Dirs() = eName$ + "/"
EndIf
EndIf
Wend
FinishDirectory(0)
If ExamineDirectory(0, dir$, pattern$)
While NextDirectoryEntry(0)
eName$ = DirectoryEntryName(0)
If (eName$ <> ".") And (eName$ <> "..")
If FindString(eName$,".DS_") = 0
AddElement(dList())
FileCount = FileCount + 1
dList() = dir$ + eName$
If DirectoryEntryType(0) = #PB_DirectoryEntry_Directory
dList() + "/"
EndIf
EndIf
EndIf
Wend
FinishDirectory(0)
EndIf
EndIf
If ListSize(Dirs())
ForEach Dirs()
SearchDirectory(dir$ + Dirs(), pattern$, dList(), level + 1)
Next
EndIf
If (level = 0)
ForEach dList()
dList() = Mid(dList(), Len(dir$) + 1, Len(dList()))
Next
EndIf
EndProcedure
Procedure LoadImageFromFile(ImageFileName.s)
Define ImageNo.i,adjustedwidth.i,adjustedheight.i
Define Ratio1.d,Ratio2.d,Aspect.d
Define *ImgBuffer,Length.i
Define Criteria.s
ImageNo = LoadImage(#PB_Any,ImageFilename)
If ImageNo = 0
;Change to error log for display"
Debug "Failed to create thumbnail for " + ImageFilename
ProcedureReturn
EndIf
;Keep Aspect Ratio
Ratio1 = ThumbSize/ImageWidth(ImageNo)
Ratio2 = ThumbSize/ImageHeight(ImageNo)
If Ratio1 < Ratio2
Aspect = Ratio1
Else
Aspect = Ratio2
EndIf
adjustedwidth = ImageWidth(ImageNo) * Aspect
adjustedheight = ImageHeight(ImageNo) * Aspect
ResizeImage(ImageNo,adjustedwidth,adjustedheight)
*ImgBuffer = EncodeImage(ImageNo)
length = MemorySize(*ImgBuffer)
If *ImgBuffer
length = MemorySize(*ImgBuffer)
If IsDatabase(ImageDB)
SetDatabaseBlob(ImageDB, 0, *ImgBuffer, length)
Criteria = "INSERT INTO Images (Image,Ident,FileName) values (?," + Str(Count) + ",'" + ImageFilename + "');"
DatabaseUpdate(ImageDB, Criteria)
Debug DatabaseError()
EndIf
FreeMemory(*ImgBuffer)
EndIf
FreeImage(ImageNo)
EndProcedure
Procedure StartCreation()
NewList FilesAndFolders.s()
SearchDirectory(FolderToUse, "*.jpg", FilesAndFolders())
TotalImages = ListSize(FilesAndFolders())
SetGadgetAttribute(prgStatus,#PB_ProgressBar_Maximum,TotalImages)
SetGadgetState(prgStatus,0)
Count = 0
ForEach FilesAndFolders()
Count = Count + 1
LoadImageFromFile(FolderToUse + FilesAndFolders())
SetGadgetText(txtStatus,"Created " + Str(Count) + " Thumbs of " + Str(TotalImages))
SetGadgetState(prgStatus,Count)
While WindowEvent():Wend
Next
SetGadgetText(txtStatus,"Thumbs Database Created")
SetGadgetState(prgStatus,0)
While WindowEvent():Wend
EndProcedure
Define Event.i
frmThumbs = OpenWindow(#PB_Any, 0, 0, 410, 140, "Create Thumbnail DB", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
btnChooseFolder = ButtonGadget(#PB_Any, 10, 10, 150, 30, "Choose Folder")
txtStatus = TextGadget(#PB_Any, 10, 60, 380, 20, "Idle")
prgStatus = ProgressBarGadget(#PB_Any, 10, 80, 390, 20, 0, 0)
btnDone = ButtonGadget(#PB_Any, 330, 100, 70, 30, "Done")
Repeat
Event = WaitWindowEvent()
Select event
Case #PB_Event_CloseWindow
End
Case #PB_Event_Gadget
Select EventGadget()
Case btnChooseFolder
FolderToUse = PathRequester("Select Folder","")
If FolderToUse > ""
;Delete Existing DB?
If FileExists(FolderToUse + "ImageThumbs.db")
DeleteFile(FolderToUse + "ImageThumbs.db")
EndIf
If Not CreateDB()
MessageRequester("ThumbsDB","Cannot Create Database Aborting!",#PB_MessageRequester_Ok |#PB_MessageRequester_Error)
Else
ImageDB = OpenDatabase(#PB_Any, FolderToUse + "ImageThumbs.db", "", "")
;Create the thumbs
StartCreation()
EndIf
EndIf
Case btnDone
End
EndSelect
EndSelect
ForEver
Code: Select all
UseSQLiteDatabase()
Global frmShowThumbs
Global cmbIdent, txtChooseThumb, Image_0, txtFileName, btnDone
Global FolderToUse.s,ImageDB.i
Macro FileExists(filename)
Bool(FileSize(fileName) > -1)
EndMacro
Procedure LoadIdents()
Define Criteria.s
ClearGadgetItems(cmbIdent)
Criteria = "Select Ident From Images"
DatabaseQuery(ImageDB,Criteria)
While NextDatabaseRow(ImageDB)
AddGadgetItem(cmbIdent,-1,GetDatabaseString(ImageDB,DatabaseColumnIndex(ImageDB,"Ident")))
Wend
EndProcedure
Procedure ShowThumb(Ident.s)
Define Criteria.s
Criteria = "SELECT * From Images Where Ident = " + Ident
DatabaseQuery(ImageDB,Criteria)
FirstDatabaseRow(ImageDB)
pictureSize = DatabaseColumnSize(ImageDB, DatabaseColumnIndex(ImageDB,"Image"))
SetGadgetText(txtFileName,GetFilePart(GetDatabaseString(ImageDB, DatabaseColumnIndex(ImageDB,"Filename"))))
*picture = AllocateMemory(pictureSize)
GetDatabaseBlob(ImageDB, DatabaseColumnIndex(ImageDB,"Image"), *picture, pictureSize)
CatchImage(1, *picture, pictureSize)
SetGadgetState(Image_0, ImageID(1))
FinishDatabaseQuery(ImageDB)
FreeMemory(*picture)
EndProcedure
frmShowThumbs = OpenWindow(#PB_Any, 0, 0, 330, 300, "Show Thumbs", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
cmbIdent = ComboBoxGadget(#PB_Any, 10, 40, 150, 25)
txtChooseThumb = TextGadget(#PB_Any, 10, 10, 150, 20, "Choose Thumbnail")
Image_0 = ImageGadget(#PB_Any, 10, 70, 150, 150, 0, #PB_Image_Border)
txtFileName = TextGadget(#PB_Any, 10, 230, 310, 20, "File Name")
btnDone = ButtonGadget(#PB_Any, 220, 260, 90, 25, "Done")
FolderToUse = PathRequester("Select Folder","")
If FolderToUse > ""
If FileExists(FolderToUse + "ImageThumbs.db")
ImageDB = OpenDatabase(#PB_Any, FolderToUse + "ImageThumbs.db", "", "")
EndIf
If Not IsDatabase(ImageDB)
End
EndIf
LoadIdents()
Else
End
EndIf
Repeat
Event = WaitWindowEvent()
Select event
Case #PB_Event_CloseWindow
End
Case #PB_Event_Gadget
Select EventGadget()
Case cmbIdent
ShowThumb(GetGadgetText(cmbIdent))
Case btnDone
End
EndSelect
EndSelect
ForEver
Regards
CD