If you don't know it, have a look at http://www.photools.com/
These Scripts can be used any way, but also without any kind of warranty!
If you don't agree, please leave now.
= new Script
= updated Script
Multi Database Transmission V 1.2 (06-Jun-2003) - This script transmits Images from a SourceDB to a TargetDB, preserving all Category-Assignments and Property-Entries. (And, *g*, if Mario would give us an updated Timestamp for the DatabaseImageRecords, we could merge Databases by checking which Entry is newer. Think about mobile IMatch.)
Remove Empty Categories from Database V 1.0 (30-May-2003) - This script removes all 'empty'-Categories from the active Database.
OffLineCache Garbage Collector V 1.0 (28-Jun-2003) - This script checks all existing Images in OfflineCacheFolder of the active Database and deletes ownerless OLC-Images. Additionally you can select some Categories from which you want delete the Images OfflineCache-pendants.
Photoshop Conversion (PS 5.5 + 6) V 0.9 (02-Jul-2003) - This Script combines the ManagementPower of IMatch with the ImageManipulationPower of Adobes Photoshop 6.0 in an easy to use way. This Script I have written together with Klaus Schwarzburg. Many thanks for your help, Klaus.
lcms Webgallery Creator V 0.1 (05-Oct-2002) - This script enhance the original Webgallery-Creator-Script with an ICC-Conversion-feature.
little Batch Converter V 1.2 (26-Jun-2003) - This script create resized copies, optionally with ICC-Conversion for Tiff- and Jpeg-sources. Can work with OfflineCacheImages instead of originals and can transmit all Property-, Category- and IPTC-data to the copies.
Registry Functions V 1.0 (01-Nov-2002) - A littleHelper-Script to put and retrieve Data to/from Registry in its correct DataTypes. VB usually provides only the StringType. With this Lib you can store every DataType to Registry (Byte, Integer, Long, Double, Decimal, Boolean, Variant, ...).
Debug Messages V 1.0 (08-Nov-2002) - A littleHelper-Script which handles Debugoutput in Priorityclasses. With this you can have good Informationoutput when you develope a Script and a less or no Output when run the Script in Productivity-Mode. Your DebugmessagePoints can stay in code without any (auswirkung). Usefull for future changes on your code.
Explanation
MainScript: hn_littleBatchConverter.bas
Needed Modules: [hnPublicDeclarations.lib]
[hnFncUtils.lib]
[hnClsRegKey.cls]
[hnClsTransmission.cls]
[hnClsWaitDialog.cls]
hn_littleBatchConverter.bas: (493 lines / 289 real codelines / 2 Subs / 4 Functions / 0 Properties)
1| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 2| ' 3| 4| ' 5| ' h.nogajski@web.de 6| ' http://horst.nogajski.de 7| ' 8| '-------------------------------------------------------------------------------------------------- 9| ' 10| ' Little BatchConverter Script (IMatch SAX-Basic) 11| ' 12| ' With this script you can simply create copies of an Image Selection. 13| ' You can select an Outputformat, OutputFolder and a new Imagesize. 14| ' Filenameconflicts are handled by adding next free number to a destination filename. 15| ' 16| 'V 1.1 (25-Jun-2003) 17| ' 18| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 19| '-------------------------------------------------------------------------------------------------- 20| ' 21| ' Uses / Embedds 22| ' 23| '#uses "lib\hnPublicDeclarations.lib" 24| '#uses "lib\hnFncUtils.lib" => Needs the IMatch 3 Scripthelping Type Library embedded 25| ' 26| '#uses "lib\hnClsWaitdialog.cls" 27| '#uses "lib\hnClsRegKey.cls" 28| '#uses "lib\hnClsTransmission.cls" 29| ' 30| '-------------------------------------------------------------------------------------------------- 31| ' 32| ' FunctionList: 33| ' 34| ' - Private Sub Main 35| ' - Public Sub UNSET_OBJECTS 36| ' - Private Function Dialog_initial() As Integer 37| ' - Private Function GetTargetPicT(ByRef SourcePicT As Image, ByRef k As Integer) As String 38| ' - Private Function MainDLG_func(DlgItem$, Action%, SuppValue&) As Boolean 39| ' - Private Function TempFilename(ByRef PicT As Image) As String 40| ' 41| '-------------------------------------------------------------------------------------------------- 42| ' 43| ' VersionChanges: 44| ' 45| ' V 0.5 (04-Jun-2003) initial release as beta script 46| ' 47| ' V 1.0 (24-Jun-2003) minor bugfixes and code cleaning; 48| ' 49| ' V 1.1 (25-Jun-2003) added: lcms ICC_conversion for jpeg and tiff sourcefiles 50| ' (the ICC-conversion works not on OfflineCacheImages!) 51| ' 52| '-------------------------------------------------------------------------------------------------- 53| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 54| 55| 56| Option Explicit 57| 58| 59| 'Set Values for Debugging and ErrorMessages 60| Private Const SuppressClassNotReadyMsg As Boolean = False 61| Private Const LCMS_WARNING As Boolean = True 62| Private Const DoClassDebug As Boolean = False 63| Private Const DoScriptDebug As Boolean = True 64| 65| 66| 'THE NEXT PART IS MOVED INTO "lib\hnPublicDeclarations.lib" 67| 'PLEASE CHECK AND/OR MODIFY THE SETTINGS THERE IF YOU NEED 68| ' ------------------------------------------------------------------------------------------- 69| ' lcms ICC Tools 70| ' -------------- 71| ' Public Const LCMS_TIFF_EXE As String = MacroDir & "\progs\tifficc.exe" 'Fullpath to the lcms tifficc.exe 72| ' Public Const LCMS_JPEG_EXE As String = MacroDir & "\progs\jpegicc.exe" 'Fullpath to the lcms jpegicc.exe 73| ' Public Const LCMS_SRGB_PROFILE As String = MacroDir & "\progs\lcms_sRGB.icm" 'Fullpath to the icm/icc Profile for Standard-RGB-Colorspace 74| ' Public Const LCMS_TIFF_PARAM As String = "-t0 -c2" 'Commandline parameters for the tifficc.exe 75| ' Public Const LCMS_JPEG_PARAM As String = "-t0 -c2" 'Commandline parameters for the jpegicc.exe 76| ' Public Const LCMS_TEMPDIR As String = Environ("TEMP") 'temporary dir for file conversions 77| ' 78| 79| 'Set a DPI-Resolution for Targetfiles 80| Private Const DPIResolution As Integer = 300 81| 82| 83| 'SCRIPTNAME & ScriptVersionString is needed for RegistryClasses, MsgBoxTitles etc. 84| Private Const SCRIPTNAME As String = "hn_little_BatchConverter" 85| Private Const ScriptVersionString As String = "V 1.1 (25-Jun-2003)" 86| 87| 'Is used to display Scriptname and Version as title of messageboxes and dialogs 88| Private Const DialogTitle As String = SCRIPTNAME & " " & ScriptVersionString 89| 'The IMatchVersionNumber what is needed for feature "Image.OfflineCacheImage" 90| Private Const NEEDED_IMATCH_VERSION As String = "3.2.0.0" 91| 92| 'The Objects, Arrays and Vars 93| Private WD As clsWaitdialog 94| Private Reg As clsRegKey 95| Private Trans As clsTransmission 96| Private DB As Database 97| Private Selection As Images 98| Private PicT As Image 99| Private bm As IMBitmap 100| Private bmOutFormat() As Variant 101| Private bmOutFormatStr() As String 102| Private maxPixArray() As String 103| Private OutFolder As String 104| Private FN As String 105| Private k As Integer 106| 107| 108| 109| Sub Main 110| 111| 112| On Error GoTo ErrHandler 113| 114| 'To use more or other file formats from the IMBitmap Class type in / add / modify the bmOutFormat-Array 115| 'MultiDimArray with OutputformatValues: 0 = FriendlyName | 1 = IMBitmapFormat 116| ReDim bmOutFormat(0 To 12) As Variant 117| bmOutFormat(0) = Array("JPEG 24 bit", imbfJPEG24_YUV411) 118| bmOutFormat(1) = Array("JPEG-EXIF 24 bit", imbfEXIF_JPEG411) 119| bmOutFormat(2) = Array("JPEG Grayscale", imbfJPEG8_YUV400) 120| bmOutFormat(3) = Array("TIFF 24 bit", imbfTIFF24_Uncompressed) 121| bmOutFormat(4) = Array("TIFF Grayscale", imbfTIFF8_GrayscaleYCC) 122| bmOutFormat(5) = Array("Photoshop3 24 bit",imbfPSD24) 123| bmOutFormat(6) = Array("PNG 24 bit", imbfPNG24) 124| bmOutFormat(7) = Array("PNG 8 bit", imbfPNG8) 125| bmOutFormat(8) = Array("Bitmap 24 bit", imbfBMP24) 126| bmOutFormat(9) = Array("Bitmap 8 bit", imbfBMP8) 127| bmOutFormat(10) = Array("PPM binary", imbfPPM_Binary) 128| bmOutFormat(11) = Array("ICO 24 bit", imbfICO24) 129| bmOutFormat(12) = Array("ICO 8 bit", imbfICO8) 130| 131| 'Create a simple StringArray for Listboxelement in UserDialog 132| ReDim bmOutFormatStr(LBound(bmOutFormat) To UBound(bmOutFormat)) 133| For k = LBound(bmOutFormat) To UBound(bmOutFormat) 134| bmOutFormatStr(k) = bmOutFormat(k)(0) 135| Next k 136| If DoScriptDebug Then hn_debugPrintArray(bmOutFormatStr) 137| 138| ReDim maxPixArray(0 To 10) As String 139| maxPixArray(0) = " 32" 140| maxPixArray(1) = " 200" 141| maxPixArray(2) = " 400" 142| maxPixArray(3) = " 600" 143| maxPixArray(4) = " 800" 144| maxPixArray(5) = "1000" 145| maxPixArray(6) = "1200" 146| maxPixArray(7) = "1400" 147| maxPixArray(8) = "1600" 148| maxPixArray(9) = "1800" 149| maxPixArray(10) = "2000" 150| 151| 152| 'Check LibVersions and initialize global Variables 153| If hnPuplicDeclarationsLibCheckVersionAgainst(12200) Then 154| InitializeGlobalVars 155| Else 156| GoTo Escape 157| End If 158| 159| If Not hnFncUtilsLibCheckVersionAgainst(13000) Then GoTo Escape 160| 161| 'Check ClassVersions and initialize ClassInstances and Objects 162| Dim RegKeyClassInstanceName As String 163| RegKeyClassInstanceName = SCRIPTNAME 164| 165| Set Reg = New clsRegKey 166| If Not Reg.CheckVersionAgainst(8000) Then GoTo Escape 167| If Reg.ClassInit(RegKeyClassInstanceName) <> -1 Then 168| MsgBox DialogTitle & vbNewLine & vbNewLine & "Couldn't initialize the Script-RegKeyClass!" & vbNewLine & "(" & RegKeyClassInstanceName & ")" & vbNewLine & "Script stops now!", vbExclamation, DialogTitle 169| GoTo Escape 170| End If 171| 172| Set DB = Application.ActiveDatabase 173| If DB Is Nothing Then 174| MsgBox DialogTitle & vbNewLine & vbNewLine & "We have no open database!" & vbNewLine & "Script stops now!", vbExclamation, DialogTitle 175| GoTo Escape 176| End If 177| 178| Set Selection = DB.ActiveSelection 179| If Selection Is Nothing Or Selection.Count = 0 Then 180| MsgBox DialogTitle & vbNewLine & vbNewLine & "We have no valid ImageSelection!" & vbNewLine & "Script stops now!", vbExclamation, DialogTitle 181| GoTo Escape 182| End If 183| 184| Set Trans = New clsTransmission 185| If Not Trans.CheckVersionAgainst(200) Then GoTo Escape 186| If Trans.ClassInit(Reg, DB, DB, SuppressClassNotReadyMsg, DoClassDebug) <> -1 Then 187| MsgBox DialogTitle & vbNewLine & vbNewLine & "Couldn't initialize the TransmissionClass!" & vbNewLine & "Script stops now!", vbExclamation, DialogTitle 188| GoTo Escape 189| End If 190| 191| Set WD = New clsWaitdialog 192| If Not Reg.CheckVersionAgainst(10000) Then GoTo Escape 193| 194| 195| 196| 'Open the Maindialog 197| If Dialog_initial <> -1 Then GoTo Escape 'If it doesn't return True, we stop the script. 198| 199| 200| 'Start Batchprocess 201| DB.Redraw = False 202| 203| Dim maxPix As Integer, newW As Integer, newH As Integer 204| maxPix = CInt(maxPixArray(Reg.GetKey("ScaleTo"))) 205| k = Reg.GetKey("k") 206| If DoScriptDebug Then 207| Debug.Print "OutputFolder = " & OutFolder 208| Debug.Print k & " " & bmOutFormat(k)(0) & " " & bmOutFormat(k)(1) 209| Debug.Print "scale Images to max pix = " & maxPix 210| End If 211| 212| 213| 'Initialize WaitdialogClass 214| If WD.ClassInit(Selection.Count, "little BatchConversion with IMBitmap Class", True, SCRIPTNAME, ScriptVersionString) <> -1 Then 215| MsgBox DialogTitle & vbNewLine & "Couldn't initialize the WaitDialogClass!" & vbNewLine & "Script stops now!", vbExclamation, DialogTitle 216| GoTo Escape 217| End If 218| 219| 220| For Each PicT In Selection 221| 222| WD.CountProcessedFile 223| WD.SetLine2_SourcefileInfo(PicT.FileName, True) 224| If DoScriptDebug Then Debug.Print "... processing file: " & PicT.Name 225| 226| 227| If PicT.IsOnline Then 228| 229| 'Try to get the original Image or OfflinecacheImage, depending on the users choice and what is available 230| If Reg.GetKey("use_OLC") Then 231| 232| If Application.Version >= NEEDED_IMATCH_VERSION Then 233| WD.SetLine3("... loading OfflineCacheImage into IMBitmap") 234| Set bm = DB.GetOfflineCacheImage(PicT) 235| End If 236| 237| If bm Is Nothing Then 238| Set bm = New IMBitmap 239| bm.LoadFile(TempFilename(PicT, "... loading orig. Image instead of OfflineCache"),24) 240| End If 241| 242| Else 243| 244| Set bm = New IMBitmap 245| WD.SetLine3("... loading Image into IMBitmap") 246| bm.LoadFile(TempFilename(PicT,"... loading Image into IMBitmap"),24) 247| 248| End If 249| 250| Else 251| 252| 'Because the Image is offline we try to get the OfflineCacheImage if available 253| WD.SetLine3("... try loading OfflineCacheImage") 254| If Application.Version >= NEEDED_IMATCH_VERSION Then 255| Set bm = DB.GetOfflineCacheImage(PicT) 256| End If 257| 258| End If 259| 260| 261| If bm Is Nothing Then 262| 263| WD.CountSkippedFile 264| If DoScriptDebug Then Debug.Print "Error loading file: " & PicT.FileName 265| 266| Else 267| 268| 269| 'Build a valid Targetfilename 270| FN = hn_AppendNextFreeNumberToFN(GetTargetPicT(PicT,k)) 271| If DoScriptDebug Then Debug.Print "... destination filename: " & FN 272| 273| 274| WD.SetLine3("... scaling") 275| If Not (bm.Height < maxPix And bm.Width < maxPix) Then 276| If bm.Width > bm.Height Then 277| newW = maxPix 278| newH = CInt(bm.Height*(maxPix/bm.Width)) 279| Else 280| newW = CInt(bm.Width*(maxPix/bm.Height)) 281| newH = maxPix 282| End If 283| If DoScriptDebug Then Debug.Print " scaling: bmW:" & bm.Width & " => " & newW & vbNewLine & " bmH:" & bm.Height & " => " & newH 284| 'If DoScriptDebug Then Debug.Print " control: bmW/bmH = " & bm.Width/bm.Height & vbNewLine & " newW/newH = " & newW/newH 285| bm.Resize(newW,newH) 286| End If 287| bm.SetDPIResolution(DPIResolution,DPIResolution) 288| 289| WD.SetLine3("... save as " & bmOutFormat(k)(0)) 290| bm.SaveFile(FN,bmOutFormat(k)(1)) 291| 292| 'Add Image to DB 293| WD.SetLine3("... adding to DB") 294| hn_AddImageToDB(FN,DB) 295| 296| 'Transmit Properties, Categories, IPTC, if selected 297| Trans.TransmitAllSelected(PicT, DB.GetImages(FN)) 298| 299| End If 300| 301| 'refresh statusbar and waitdialog 302| WD.SetPercentage 303| If WD.UserHasCanceled Then Exit For 304| 305| Next PicT 306| 307| WD.Closes 308| WD.ProcessSummaryMessageBox 309| 310| WD.ClassUNSET 311| Trans.ClassUNSET 312| Reg.ClassUNSET 313| 314| 315| Escape: 316| UNSET_OBJECTS 317| Exit Sub 318| 319| ErrHandler: 320| ErrMsg(Err) 321| Resume Escape 322| 323| End Sub 324| 325| Public Sub UNSET_OBJECTS 326| FreeObject(WD) 327| FreeObject(Reg) 328| FreeObject(Trans) 329| FreeObject(DB) 330| FreeObject(Selection) 331| FreeObject(PicT) 332| FreeObject(bm) 333| End Sub 334| 335| 336| Private Function Dialog_initial() As Integer 337| 338| On Error GoTo ErrHandler 339| 340| 341| Begin Dialog UserDialog 520,301,DialogTitle,.MainDLG_func ' %GRID:10,7,1,1 342| CancelButton 330,252,170,21 343| OKButton 330,273,170,21 344| PushButton 330,231,170,21,"Instructions for use",.Btn_Info 345| GroupBox 20,7,480,98,"Please select an OutputFormat and OutputFolder:",.GroupBox2 346| DropListBox 40,49,440,238,bmOutFormatStr(),.k 347| GroupBox 37,70,445,22,"",.GroupBox6 348| GroupBox 200,119,120,98,"",.GroupBox4 349| DropListBox 220,147,80,147,maxPixArray(),.ScaleTo 350| GroupBox 20,119,170,98,"",.GroupBox1 351| GroupBox 330,119,170,56,"",.GroupBox3 352| GroupBox 330,182,170,35,"",.GroupBox5 353| Text 80,78,390,13,"",.Str_folder 354| Text 210,119,100,14,"scale to maxPix",.Text3 355| PushButton 40,77,30,14,"...",.Btn_folder 356| Text 340,133,150,35,"Try to create copies from the offlinecache if available",.Text2 357| Text 340,196,150,14,"Tiff + Jpeg source only",.Text5 358| PushButton 30,112,150,21,"select Transmissions",.SelectTrans 359| Text 40,140,140,70,"",.TransText 360| CheckBox 340,119,140,14,"use OfflineCache",.use_OLC 361| CheckBox 340,182,150,14,"do ICC conversion",.DoICC 362| Text 40,28,440,14,"active Selection = " & Selection.Count & " Images",.Text4,1 363| Picture 30,231,270,56,MacroDir & "\icons\batchconverterlogo.bmp",0,.Picture1 364| End Dialog 365| 366| 367| Dim dlg As UserDialog 368| 369| With dlg 370| .ScaleTo = Reg.GetKey("ScaleTo", 5) 371| .k = Reg.GetKey("k", 1) 372| .use_OLC = Reg.GetKey("use_OLC", False) 373| .DoICC = Reg.GetKey("DoICC", False) 374| End With 375| 376| Dialog_initial = Dialog(dlg) 377| If Dialog_initial <> -1 Then GoTo Escape 378| 379| Reg.SaveKey("ScaleTo", dlg.ScaleTo, AsInteger) 380| Reg.SaveKey("k", dlg.k, AsInteger) 381| Reg.SaveKey("use_OLC", dlg.use_OLC, AsBoolean) 382| Reg.SaveKey("DoICC", dlg.DoICC, AsBoolean) 383| 384| Escape: 385| Exit Function 386| 387| ErrHandler: 388| ErrMsg(Err) 389| Resume Escape 390| 391| End Function 392| 393| 394| 395| Private Function MainDLG_func(DlgItem$, Action%, SuppValue&) As Boolean 396| 397| On Error GoTo ErrHandler 398| 399| Select Case Action% 400| 401| Case 1 402| 'WinTransparentSet(DialogTitle) 403| DlgText("Str_folder", Reg.GetKey("Str_folder",Application.GetApplicationVariable("OutputFolder"))) 404| DlgText("TransText", Trans.DisplaySelectedTransmissions) 405| 406| Case 2 407| 408| Select Case DlgItem$ 409| 410| Case "SelectTrans" 411| Trans.TheDialog 412| MainDLG_func = True 413| 414| Case "Btn_folder" 415| OutFolder = hn_BuildFolderStr(Application.BrowseForFolder(DlgText("Str_folder"),"select an Outputfolder please"),,False) 416| If OutFolder <> "\" And OutFolder <> "" Then DlgText("Str_folder", OutFolder) 417| MainDLG_func = True 418| 419| Case "OK" 420| Reg.SaveKey("Str_folder",DlgText("Str_folder")) 421| OutFolder = DlgText("Str_folder") 422| 423| Case "Btn_Info" 424| Dim Imsg As String 425| Imsg = "Instructions for use:" & vbNewLine & vbNewLine & _ 426| "This script lets you choose an outputformat, outputfolder, and a new size for your copies." & vbNewLine & vbNewLine & _ 427| "Optionally you can transmit Property-, Category- and IPTC-Data to the new Images." & vbNewLine & vbNewLine & "You can use OfflineCacheImages as source, if available." & vbNewLine & vbNewLine & _ 428| "You can do ICC_Conversion with the lcms-tools via shell execution. This works only for Tiff and Jpeg sourcefiles and only with the original files, not with the offlinecache." & vbNewLine & vbNewLine & _ 429| "But you can select all together, the script takes care for all settings," & vbNewLine & _ 430| "e.g. if you have checked 'use OfflineCacheImages', the script uses this if available. If is not available, it uses the original." & vbNewLine & _ 431| "If this is also not available the script continues with next file." & vbNewLine & vbNewLine & _ 432| "So you can work with a selection of Images where are some have an OfflineCacheImage and some have not." & vbNewLine & _ 433| "Also you can check DoICC-Conversion do work on the original Images in that selection." & vbNewLine & vbNewLine & _ 434| "On filename conflicts the script adds next free number to destination filename," & vbNewLine & _ 435| " e.g. filename.jpg => filename_(2).jpg." & vbNewLine & vbNewLine & _ 436| "For more information or other scripts go to my IMatch Scriptsection on http://horst.nogajski.de/imatch/" 437| MsgBox Imsg, vbInformation, DialogTitle 438| MainDLG_func = True 439| 440| End Select 441| 442| DlgText("TransText", Trans.DisplaySelectedTransmissions) 443| 444| End Select 445| 446| Escape: 447| Exit Function 448| 449| ErrHandler: 450| ErrMsg(Err) 451| Resume Escape 452| 453| End Function 454| 455| Private Function GetTargetPicT(ByRef SourcePicT As Image, ByRef k As Integer) As String 456| 457| On Error GoTo ErrHandler 458| 459| GetTargetPicT = hn_BuildFolderStr(OutFolder) & hn_FileStrObject(SourcePicT.FileName).FName & bm.FileExtensionForFormat(bmOutFormat(k)(1)) 460| 461| Escape: 462| Exit Function 463| 464| ErrHandler: 465| ErrMsg(Err) 466| Resume Escape 467| 468| End Function 469| 470| Private Function TempFilename(ByVal PicT As Image, ByVal line3txt As String) As String 471| 472| On Error GoTo ErrHandler 473| 474| If Reg.GetKey("DoICC") Then 475| WD.SetLine3("... do lcms ICC-Conversion via Shell") 476| If DoScriptDebug Then Debug.Print "... do lcms ICC-Conversion via Shell" 477| TempFilename = hn_lcmsConversion(PicT.FileName) 478| Else 479| TempFilename = PicT.FileName 480| End If 481| 482| WD.SetLine3(line3txt) 483| 484| Escape: 485| Exit Function 486| 487| ErrHandler: 488| ErrMsg(Err) 489| Resume Escape 490| 491| End Function 492| 493|