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_RemoveEmptyCategoriesFromDatabase.bas
Needed Modules: [hnFncRegKey.lib]
hn_RemoveEmptyCategoriesFromDatabase.bas: (376 lines / 219 real codelines / 1 Sub / 4 Functions / 0 Properties)
1| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 2| ' 3| 4| ' 5| ' h.nogajski@web.de 6| ' http://horst.nogajski.de 7| ' 8| '-------------------------------------------------------------------------------------------------- 9| ' 10| ' RemoveEmptyCategoriesFromDatabase (IMatch SAX-Basic) 11| ' 12| ' This Script removes all Categories where _all_ of the following Properties are True: 13| ' - 1) Cat is Imageless 14| ' - 2) Cat has no FormulaExpressions 15| ' - 3) Cat has no Child-Categories with Images or FormulaExpressions 16| ' - 4) Cat is not a Cat or a Child-Cat from the ExclusionList 17| ' 18| ' (This Script is a modification of Peter Meinhardts Script "Mei_RemoveEmptyFoldersFromDB.bas") 19| ' 20| 'V 1.0 (30-May-2003) 21| ' 22| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 23| '-------------------------------------------------------------------------------------------------- 24| ' 25| ' Uses / Embedds 26| ' 27| '#uses "lib\hnFncRegKey.lib" 28| ' 29| '-------------------------------------------------------------------------------------------------- 30| ' 31| ' VersionChanges: 32| ' 33| ' V 1.0 (30-May-2003) initial release 34| ' 35| '-------------------------------------------------------------------------------------------------- 36| ' 37| ' Credits: 38| ' 39| ' Thanks to Peter Meinhardt for his Mei_RemoveEmptyFoldersFromDatabase-Script 40| ' 41| '-------------------------------------------------------------------------------------------------- 42| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 43| 44| 45| 46| Option Explicit 47| 48| 49| 'SCRIPTNAME & ScriptVersionString is needed for RegistryClasses, MsgBoxTitles etc. 50| Private Const SCRIPTNAME As String = "_RemoveEmptyCatsFromDB" 51| Private Const ScriptVersionString As String = "V 1.0 (30-May-2003)" 52| 53| 54| 'Needed for the RegKey-Functions 55| Public Const My_RegKeyApp As String = "photools.com\IMatch.3" 56| Public Const My_RegKeySection As String = "Scripts\hn_RemCatFDB" 57| 58| 59| 'Needed to concatenate Targetfilename with selected Folder from BrowseForFolderDialog 60| Private Const LOGFILENAME As String = "RemoveEmptyCats_LogFile.txt" 61| 62| 63| 'Needed for the FileExists-Function 64| Private Enum DirParams 65| vbNormal = vbNormal 66| vbDirectory = vbDirectory 67| vbVolume = vbVolume 68| End Enum 69| 70| 71| Private DB As Database 72| Private Cats As Categories 73| Private ExcludedCats As Categories 74| Private ExcList() As String 75| 76| 77| Sub Main 78| 79| On Error GoTo ErrHandler 80| 81| If hnfncregkeyLibVersion < 10100 Then GoTo NoValidLib 82| 'User Hint: If Script gives an error here (missing the revision scalar variable) you have 83| ' overwritten the file hnfncregkey.lib contained in the ZIP file of this Script 84| ' with an outdated version delivered with another script in your Script folder. 85| ' Please reinstall the file from the ZIP file of this Script. 86| 87| Dim k As Long, prcnt As Long, fldCount As Long, ErrorFlag As Long 88| Dim Tot1 As Long, Tot2 As Long, num As Long, delta As Long, delFld As Long 89| Dim maxPrc As Long 90| Dim Removed As Boolean 91| Dim started As Double, duration As Double 92| 93| Set DB = Application.ActiveDatabase 94| If DB Is Nothing Then 95| MsgBox "Please open a database first!" 96| Exit Sub 97| End If 98| Set Cats = DB.Categories 99| 100| 101| Begin Dialog UserDialog 830,287,"Remove imageless categories from Database " & ScriptVersionString,.DLG_func ' %GRID:10,7,1,1 102| GroupBox 610,7,210,147,"Exclusions (ParentCats):",.GroupBox3 103| GroupBox 10,7,590,147,"Purpose:",.GroupBox1 104| GroupBox 10,161,590,105,"Protocol:",.GroupBox2 105| Text 50,28,540,70,"This Script removes all Categories where _all_ of the following Properties are True:" & vbNewLine & " - 1) Cat is Imageless" & vbNewLine & " - 2) Cat has no FormulaExpressions" & vbNewLine & " - 3) Cat has no Child-Categories with Images or FormulaExpressions" & vbNewLine & " - 4) Cat is not a Cat or a Child-Cat from the ExclusionList",.Text6 106| Text 20,105,570,14,"Instructions on usage:",.Text3 107| Text 50,119,540,28,"After clicking OK the whole active Database is scanned for imageless categories which will be removed from the Database.",.Text5 108| OKButton 720,245,90,21 109| CancelButton 620,245,90,21 110| Text 30,175,420,14,"The removed folders protocol will be written to:",.Text4 111| TextBox 30,196,410,21,.TargetFile 112| PushButton 460,196,130,21,"Browse...",.BtnBrowse 113| OptionGroup .Group1 114| OptionButton 30,224,270,14,"Empty File before adding new lines",.CheckEmptyFile 'otherwise the new lines will be appended 115| OptionButton 30,238,270,14,"Append New lines",.CheckAppend 116| PushButton 400,238,190,21,"Show Logfile",.BtnShowLog 117| PushButton 620,28,190,21,"select Cats for Exclusion",.BtnExcCats 118| ListBox 620,56,190,91,ExcList(),.ExcListBox,3 119| Picture 610,168,210,56,MacroDir & "\icons\removecatslogo.bmp",0,.Picture1 120| End Dialog 121| 122| 123| Dim dlg As UserDialog 124| dlg.TargetFile = GetRegKey("TargetFile", Environ("TEMP") & "\" & LOGFILENAME) 125| dlg.Group1 = GetRegKey("Group1", 0) 126| 127| 128| If Dialog(dlg) <> -1 Then 129| Exit Sub 130| End If 131| 132| 133| SaveRegKey("TargetFile",CStr(dlg.TargetFile)) 134| SaveRegKey("Group1",CInt(dlg.Group1)) 135| 136| 137| started = Timer 138| 139| If dlg.Group1 = 0 Then 140| Open dlg.TargetFile For Output As #1 141| Else 142| Open dlg.TargetFile For Append As #1 143| End If 144| 145| DB.Redraw = False 146| 147| Print #1, "===================== Start " & Time 148| Print #1,"Total number of categories in Database: " & CStr(Cats.Count) 149| Tot1 = Cats.Count 150| num = 0 151| maxPrc = Application.ActiveDatabase.Categories.Count 152| 153| 'initialize statusbar and waitdialog 154| Dim MainWaitDialogText As String 155| Dim curInt As Integer, allInt As Integer 156| curInt = 0 157| MainWaitDialogText = "Removing empty categories out of " & CStr(Application.ActiveDatabase.Categories.Count) & vbNewLine 158| 'start statusbar and waitdialog 159| Application.StatusBarSetText MainWaitDialogText 160| Application.StatusBarShowPercentage 0, maxPrc 161| Application.WaitDialogOpen MainWaitDialogText, 0, maxPrc, True 162| 163| 164| delFld = 0 165| fldCount = Application.ActiveDatabase.Categories.Count 166| k = 1 167| prcnt = 1 168| If k <= fldCount Then 169| DirLoop: 170| delta = delFld 171| Removed = TestRemoveCategory(Application.ActiveDatabase.Categories.Item(k), delFld) 172| k = k + 1 + delta - delFld 173| prcnt = prcnt + 1 174| If prcnt <= maxPrc Then 175| Application.StatusBarSetPercentage prcnt 176| Application.WaitDialogSetPercentage prcnt 177| End If 178| If Application.WaitDialogIsCanceled Then GoTo BreakLoop 179| If k <= Application.ActiveDatabase.Categories.Count Then GoTo DirLoop 180| BreakLoop: 181| End If 182| 183| num = num + delFld 184| 185| Tot2 = Tot1 - Application.ActiveDatabase.Categories.Count 186| duration = Timer - started 187| If duration < 0 Then duration = duration + 24.0*3600 188| Print #1, CStr(Tot2) & " categories removed from Database in " & CStr(duration) & " seconds" 189| DB.Redraw = True 190| Application.StatusBarHidePercentage 191| Application.WaitDialogClose 192| MsgBox CStr(Tot2) & " categories removed from Database in " & CStr(duration) & " seconds", vbInformation, "hn_RemoveEmptyCategoriesFromDatabase" 193| GoTo Escape 194| 195| 196| NoValidLib: 197| MsgBox "Library hnFncRegKey.lib Version 1.1 or higher required in Script folder", vbCritical, "hn_RemoveEmptyCategoriesFromDatabase" 198| 199| Escape: 200| Close #1 201| If Not Cats Is Nothing Then Set Cats = Nothing 202| If Not ExcludedCats Is Nothing Then Set ExcludedCats = Nothing 203| Exit Sub 204| 205| ErrHandler: 206| MsgBox "ErrorNumber: " & Err.Number & vbNewLine & "Description: " & Err.Description 207| Resume Escape 208| 209| End Sub 210| 211| 212| Private Function TestRemoveCategory(ByRef dcat As Category, ByRef delFld As Long) As Boolean 213| 214| On Error GoTo ErrHandler 215| 216| Debug.Print dcat.Name & " : " & delFld 217| Dim ParentCat As Category 218| 219| 220| If ((dcat.Children.Count = 0) And (dcat.Images.Count = 0) And (dcat.Formula = "") And IsNotExcluded(dcat)) Then 221| Print #1, dcat.FullName 222| Set ParentCat = dcat.Parent 223| Application.ActiveDatabase.RemoveCategory(dcat) 224| TestRemoveCategory = True 225| delFld = delFld + 1 226| If Not (ParentCat Is Nothing) Then TestRemoveCategory(ParentCat, delFld) 'recursive upward deletion if parent is also imageless 227| End If 228| 229| Escape: 230| Exit Function 231| 232| ErrHandler: 233| If Not Err.Number = -2147467259 Then MsgBox "ErrorNumber: " & Err.Number & vbNewLine & "Description: " & Err.Description 234| Resume Escape 235| 236| End Function 237| 238| Private Function IsNotExcluded(ByRef dcat As Category) As Boolean 239| 240| On Error GoTo ErrHandler 241| 242| If Not ExcludedCats Is Nothing Then 243| 244| Dim s1 As String, s2 As String 245| Dim ExcCat As Category 246| 247| s1 = dcat.FullName 248| 249| For Each ExcCat In ExcludedCats 250| s2 = ExcCat.FullName 251| 'Debug.Print Left(s1, Len(s2)) & " = " & s2 252| If Left(s1, Len(s2)) = s2 Then GoTo Escape 253| Next 254| 255| IsNotExcluded = True 256| 257| Else 258| 259| IsNotExcluded = True 260| 261| End If 262| 263| Escape: 264| Set ExcCat = Nothing 265| Exit Function 266| 267| ErrHandler: 268| MsgBox "ErrorNumber: " & Err.Number & vbNewLine & "Description: " & Err.Description 269| Resume Escape 270| 271| End Function 272| 273| 274| Rem See DialogFunc help topic for more information. 275| Private Function DLG_func(DlgItem$, Action%, SuppValue&) As Boolean 276| 277| On Error GoTo ErrHandler 278| 279| 280| Select Case Action% 281| 282| Case 1 ' Dialog box initialization 283| If hn_FileExists(DlgText("TargetFile"),vbNormal) Then 284| DlgEnable("BtnShowLog",True) 285| Else 286| DlgEnable("BtnShowLog",False) 287| End If 288| 289| 290| Case 2 ' Value changing or button pressed 291| Select Case DlgItem$ 292| 293| Case "BtnExcCats" 294| Set ExcludedCats = DB.SelectCategoriesDialog(ExcludedCats, False) 295| If Not ExcludedCats Is Nothing Then 296| Dim Cat As Category, i As Integer 297| ReDim ExcList(0 To ExcludedCats.Count -1) 298| For Each Cat In ExcludedCats 299| ExcList(i) = Cat.FullName 300| i = i +1 301| Next Cat 302| End If 303| DlgListBoxArray "ExcListBox", ExcList() 304| DLG_func = True 305| 306| Case "BtnBrowse" 307| Dim NewTargetfilename As String 308| NewTargetfilename = Application.BrowseForFolder(DlgText("TargetFile"),"Browse for Outputfolder") 309| If NewTargetfilename <> "" Then 310| NewTargetfilename = NewTargetfilename & "\" & LOGFILENAME 311| DlgText("TargetFile",NewTargetfilename) 312| End If 313| DLG_func = True 314| 315| Case "BtnShowLog" 316| If hn_FileExists(DlgText("TargetFile"),vbNormal) Then 317| Application.ShellExecute("open",DlgText("TargetFile")) 318| End If 319| DLG_func = True 320| 321| Case "ExcListBox" 322| DLG_func = True 323| 324| End Select 325| 326| 327| Case 3 ' TextBox or ComboBox text changed 328| If DlgItem$ = "TargetFile" Then 329| If hn_FileExists(DlgText("TargetFile"),vbNormal) Then 330| DlgEnable("BtnShowLog",True) 331| Else 332| DlgEnable("BtnShowLog",False) 333| End If 334| End If 335| 336| End Select 337| 338| Escape: 339| Exit Function 340| 341| ErrHandler: 342| MsgBox "ErrorNumber: " & Err.Number & vbNewLine & "Description: " & Err.Description 343| Resume Escape 344| 345| End Function 346| 347| 348| Private Function hn_FileExists(ByVal FullpathFileName As String, Optional DirAttr As DirParams = vbNormal) As Boolean 349| 350| On Error GoTo ErrHandler 351| 352| hn_FileExists = False 353| If Len(Dir(FullpathFileName,DirAttr)) <> 0 Then hn_FileExists = True 354| 355| Escape: 356| Exit Function 357| 358| ErrHandler: 359| MsgBox "ErrorNumber: " & Err.Number & vbNewLine & "Description: " & Err.Description, vbExclamation, "Error" 360| Resume Escape 361| 362| End Function 363| 364| 365| 366| '### FunctionList: 367| ' - Private Function DLG_func(DlgItem$, Action%, SuppValue&) As Boolean 368| ' - Private Function IsNotExcluded(ByRef dcat As Category) As Boolean 369| ' - Private Function TestRemoveCategory(ByRef dcat As Category, ByRef delFld As Long) As Boolean 370| ' - Private Function hn_FileExists(ByVal FullpathFileName As String, Optional DirAttr As DirParams = vbNormal) As Boolean 371| ' - Sub Main 372| 373| '### Public Declarations: 374| ' - Public Const My_RegKeyApp As String = "photools.com\IMatch.3" 375| ' - Public Const My_RegKeySection As String = "Scripts\hn_RemCatFDB" 376|