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_MultiDBTransmission.bas
Needed Modules: [hnClsRegKey.cls]
[hnClsTransmission.cls]
[hnFncUtils.lib]
[hnPublicDeclarations.lib]
hn_MultiDBTransmission.bas: (951 lines / 605 real codelines / 3 Subs / 8 Functions / 0 Properties)
1| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 2| ' 3| 4| ' 5| ' h.nogajski@web.de 6| ' http://horst.nogajski.de 7| ' 8| '-------------------------------------------------------------------------------------------------- 9| ' 10| ' Multi Database Transmission Script (IMatch SAX-Basic) 11| ' 12| ' With this Script you can transmit Images from SourceDB to TargetDB 13| ' with preserving the Category-Assignments and Property-Entries 14| ' 15| ' 16| 'V 1.2 (06-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 Sub CheckDBintegrity 37| ' - Private Function AddThisImageToDB(ByRef PicT As Image, ByRef TargetDB As Database, ByRef SourceDB As Database) As Boolean 38| ' - Private Function BuildIBuckFileName(ByRef DB As Database) As String 39| ' - Private Function Dialog_Initial_Func(DlgItem$, Action%, SuppValue&) As Boolean 40| ' - Private Function Dialog_initial() As Integer 41| ' - Private Function MakeProcFooter(ByRef curInt As Integer, ByRef TotalFileSize As Double, ByRef Duration As Double, ByRef StartTime As Double) As String 42| ' - Private Function SaveLog(ByRef ProcHeader As String, ByRef ProcFooter As String, ByRef ProcBody As String) 43| ' - Private Function SetDlgItems(ByRef Enabled As Boolean, ByRef MainWarnText As String, ByRef WarnText As String) 44| ' - Private Function SourceText(ByRef Enabled As Boolean) As String 45| ' 46| '-------------------------------------------------------------------------------------------------- 47| ' 48| ' VersionChanges: 49| ' 50| ' V 1.0 (02-Jun-2003) initial release 51| ' 52| ' V 1.1 (03-Jun-2003) BugFix: AddThisImageToDB() changed so that it now can check in 53| ' SourceDB for the IM-Rootfolder of an Image and pass its name to 54| ' the hn_AddImageToDB-Function. Now the new Images will added to 55| ' TargetDB with respect to the original FolderTreeStructure. 56| ' 57| ' V 1.2 (06-Jun-2003) Better Errorhandling: I have had problems with some 58| ' PhotoshopImages > 600 MB by adding to TargetDB. Now there is an 59| ' additional check if the Image was really added to TargetDB. 60| ' New: TargetPicT as ImageObject; better Process Summary; 61| ' Logfilecreation; 62| ' 63| '-------------------------------------------------------------------------------------------------- 64| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 65| 66| 67| 68| Option Explicit 69| 70| 71| 'SCRIPTNAME & ScriptVersionString is needed for RegistryClasses, MsgBoxTitles etc. 72| Private Const SCRIPTNAME As String = "Multi_DB_Transmission" 73| Private Const ScriptVersionString As String = "V 1.2 (06-Jun-2003)" 74| 75| 76| 'Set a value for global handling of all inherent classes and the mainscript 77| Private Const SuppressClassNotReadyMsg As Boolean = False 78| Private Const DoClassDebug As Boolean = False 79| Private Const DoScriptDebug As Boolean = True 80| 81| 82| 'Set this to True if you want to safe OfflineImageNames from Selections to BucketFiles, 83| 'so that you also can select these in later ScriptRuns as activeSelection, 84| '(e.g. after these Images are online again) 85| 'NOTE: in IMatch Version 3.3.0.6 (and some priors till 3.2.0.18) there is a bug which let 86| ' us not use the Bucket.Load and Bucket.Save methods. 87| ' There is a workaround via Scripting but this is very slow :( 88| ' After Mario has released a patch where this bug is fixed I will update this Script. 89| Private Const USE_BUCKETS_FOR_SELECTION As Boolean = False 90| Private Const IBuckFilePath As String = "C:\" 91| Private Const IBuckFileNamePrefix As String = "OLC-Buck_" 92| Private Const IBuckFileSuffix As String = ".ibuck" 93| 94| 95| 96| 'Modulglobal Classes + Objects (delete those you do not need) 97| Private WD As clsWaitdialog 98| Private Reg As clsRegKey 99| Private Trans As clsTransmission 100| Private DB_A As Database 101| Private DB_B As Database 102| Private dbList() As String 103| Private Selection As Images 104| Private PicT As Image 105| Private TargetPicT As Image 106| Private OLCBuck As ImageBucket 107| Private TargetCollection As ImageBucket 108| Private ErrorCollection As ImageBucket 109| Private ImportCat As Category 110| Private ParentImportCat As Category 111| Private ProcHeader As String 112| Private ProcBody As String 113| Private ProcFooter As String 114| Private NotUpdated As Long 115| Private IsOffline As Long 116| Private k As Integer 117| 118| 119| Sub Main 120| 121| On Error GoTo ErrHandler 122| 123| 'Check LibVersions and Initialize GlobalVars stored in hnPublicDeclarations: 124| 125| '#################################################### 126| '## Public Declarations and BasicFunctions 127| '## 128| If hnPuplicDeclarationsLibCheckVersionAgainst(12100) Then 129| InitializeGlobalVars 130| Else 131| GoTo Escape 132| End If 133| 134| 'Utils Function Lib 135| If Not hnFncUtilsLibCheckVersionAgainst(11000) Then GoTo Escape 136| '## 137| '#################################################### 138| 139| 140| 'Initialize all needed classes: 141| 142| '#################################################### 143| '## Setup one or more RegistryClass-Instances 144| '## 145| Dim RegKeyClassInstanceName As String 146| RegKeyClassInstanceName = SCRIPTNAME 'or set this to another (unique) name 147| 148| 'The RegistryClass-Instance in which you can store all values of Dialogs etc 149| 'All other classes also use these classInstance automaticly! 150| Set Reg = New clsRegKey 151| If Not Reg.CheckVersionAgainst(10000) Then GoTo Escape 152| If Reg.ClassInit(RegKeyClassInstanceName) <> -1 Then 153| MsgBox "Couldn't initialize the Script-RegKeyClass!" & vbNewLine & "(" & RegKeyClassInstanceName & ")", vbExclamation, "(" & SCRIPTNAME & ") stops now!" 154| GoTo Escape 155| End If 156| '## 157| '#################################################### 158| 159| 160| '#################################################### 161| '## Setup the WaitdialogClass 162| '## 163| Set WD = New clsWaitdialog 164| 'Type in the current VersionNumber of Classfile you uses for this Script: 165| If Not Reg.CheckVersionAgainst(10000) Then GoTo Escape 166| '## 167| '#################################################### 168| 169| 170| 'Open the Initial Dialog to let the user choose the SourceDB and TargetDB 171| If Dialog_initial <> -1 Then GoTo Escape 'If it doesn't return True, we stop the script. 172| 173| 174| '#################################################### 175| '## Setup the DatabaseObjects and the ImagesObject 176| '## 177| Set DB_A = Application.Databases.Item(Reg.GetKey("DSource")+1) 178| If DB_A Is Nothing Then 179| MsgBox "We have no Source-Database!", vbInformation, "(" & SCRIPTNAME & ") stops now!" 180| GoTo Escape 181| End If 182| 183| Set DB_B = Application.Databases.Item(Reg.GetKey("DTarget")+1) 184| 'If (DB Is Nothing) Or hn_FileStrObject(DB.FileName).FBasename <> WORKFLOWDATABASE Then 185| If DB_B Is Nothing Then 186| MsgBox "We have no Target-Database!", vbInformation, "(" & SCRIPTNAME & ") stops now!" 187| GoTo Escape 188| End If 189| 190| Select Case Reg.GetKey("Scope") 191| Case 0 192| Set Selection = DB_A.GetImages() 193| Case 1 194| Set Selection = DB_A.ActiveSelection 195| Case 2 196| Dim Ibuck As ImageBucket 197| Set Ibuck = DB_A.CreateImageBucket 198| hn_BucketLoad(Ibuck, BuildIBuckFileName(DB_A), DB_A) 199| Set Selection = Ibuck.Images 200| Set Ibuck = Nothing 201| End Select 202| 203| If (Selection Is Nothing) Or (Selection.Count = 0) Then 204| MsgBox "No valid selection of Images!", vbInformation, "(" & SCRIPTNAME & ") stops now!" 205| GoTo Escape 206| End If 207| 208| DB_A.Redraw = False 209| DB_B.Redraw = False 210| '## 211| '#################################################### 212| 213| 214| '#################################################### 215| '## Setup a TransmissionClassInstance with which you can transmit all Properties, Categories 216| '## 217| Set Trans = New clsTransmission 218| 'Type in the current VersionNumber of Classfile you uses for this Script: 219| If Not Trans.CheckVersionAgainst(2000) Then GoTo Escape 220| If Trans.ClassInit(Reg, DB_A, DB_B, SuppressClassNotReadyMsg, DoClassDebug) <> -1 Then 221| MsgBox "Couldn't initialize the TransmissionClass!", vbInformation, "Script (" & SCRIPTNAME & ") stops now!" 222| GoTo Escape 223| End If 224| '## 225| '#################################################### 226| 227| 228| Set OLCBuck = DB_A.CreateImageBucket 229| 230| 231| 'Initialize WaitdialogClass 232| If WD.ClassInit(Selection.Count, "Check for Offline-Images in SourceDB-Selection [" & Selection.Count & "]; Source-DB [" & hn_FileStrObject(DB_A.FileName).FName & "] ... ", False, SCRIPTNAME, ScriptVersionString) <> -1 Then 233| MsgBox "Couldn't initialize the WaitDialogClass!" & vbNewLine & vbNewLine & "Script stops now.", vbExclamation, SCRIPTNAME & " " & ScriptVersionString 234| GoTo Escape 235| End If 236| 237| For Each PicT In Selection 238| 239| WD.CountProcessedFile 240| If Not PicT.IsOnline Then 241| k = k +1 242| OLCBuck.CombineImage(PicT) 243| End If 244| WD.SetPercentage 245| 246| Next PicT 247| 248| WD.Closes 249| WD.ClassUNSET 250| 251| 252| ProcHeader = "####### Transmissions from SourceDatabase to TargetDatabase ######" & vbNewLine 253| ProcHeader = ProcHeader & vbNewLine & " SourceDatabase: " & DB_A.FileName 254| ProcHeader = ProcHeader & vbNewLine & " TargetDatabase: " & DB_B.FileName 255| ProcHeader = ProcHeader & vbNewLine & " ImageSelection: " & Selection.Count 256| ProcHeader = ProcHeader & vbNewLine & " Offline-Images: " & k 257| ProcHeader = ProcHeader & vbNewLine & " transmit Properties: " & CStr(Reg.GetKey("transProp")) 258| ProcHeader = ProcHeader & vbNewLine & " transmit Categories: " & CStr(Reg.GetKey("transCat")) 259| 260| 261| If USE_BUCKETS_FOR_SELECTION Then 262| If k > 0 Then 263| Select Case MsgBox("There are Offline-Images in the SourceDB-Selection!" & vbNewLine & vbNewLine & ProcHeader & vbNewLine & vbNewLine & "YES = Save the Names as ImageBucket for further Action and continue Transmissions." & vbNewLine & "NO = Don't save the Names, but continue Transmissions." & vbNewLine & "CANCEL = Don't save Names. Don't continue Transmissions.", vbYesNoCancel + vbDefaultButton3 + vbInformation, "There are " & k & " Offline-Images in SourceDB-Selection") 264| Case vbYes 265| Debug.Print "Saving ImageBucket under " & BuildIBuckFileName(DB_A) & " = " & hn_BucketSafe(OLCBuck, BuildIBuckFileName(DB_A)) 266| Case vbCancel 267| GoTo Escape 268| End Select 269| End If 270| Else 271| If k > 0 Then 272| If MsgBox("There are Offline-Images in the SourceDB-Selection!" & vbNewLine & vbNewLine & ProcHeader & vbNewLine & vbNewLine & "YES = Continue Transmissions and Skip OfflineImages" & vbNewLine & "NO = Don't continue!", vbYesNo + vbDefaultButton2 + vbInformation, "There are " & k & " Offline-Images in SourceDB-Selection") = vbNo Then GoTo Escape 273| End If 274| End If 275| k = 0 276| 277| 278| If Not Selection Is Nothing And Selection.Count > 0 Then 279| 280| Dim StartTime As Double, Duration As Double 281| Dim ShowSummary As Boolean 282| ProcHeader = ProcHeader & vbNewLine & vbNewLine & " Process started: " & Now 283| StartTime = Timer 284| Set TargetCollection = DB_B.CreateImageBucket 285| Set ErrorCollection = DB_A.CreateImageBucket 286| 287| 288| 'Initialize WaitdialogClass 289| If WD.ClassInit(Selection.Count, "Add Images (" & Selection.Count & ") from Source-DB [" & hn_FileStrObject(DB_A.FileName).FName & "] to Target-DB [" & hn_FileStrObject(DB_B.FileName).FName & "] ... ") <> -1 Then 290| MsgBox "Couldn't initialize the WaitDialogClass!" & vbNewLine & vbNewLine & "Script stops now.", vbExclamation, SCRIPTNAME & " " & ScriptVersionString 291| GoTo Escape 292| End If 293| 294| 295| If DoScriptDebug Then 296| Debug.Print ProcHeader & vbNewLine 297| Debug.Print " ... processing Images ..." 298| End If 299| 300| 301| Dim ActionResult As Boolean 302| For Each PicT In Selection 303| 304| WD.CountProcessedFile 305| WD.SetLine2_SourcefileInfo(PicT.FileName) 306| 307| If PicT.IsOnline Then 308| 309| If DoScriptDebug Then Debug.Print " " & WD.ProcessSummary.procFiles & " " & PicT.FileName 310| If Reg.GetKey("DoLog") Then ProcBody = ProcBody & vbNewLine & " " & WD.ProcessSummary.procFiles & " " & PicT.FileName 311| 312| 'Action 1 313| WD.SetLine3("... adding Image to Target-DB") 314| If AddThisImageToDB(PicT, DB_B, DB_A) Then 315| 316| 'additional check if the Image was really added to TargetDB 317| 'I have had problems with some PhotoshopImages > 600 MB 318| 319| Set TargetPicT = DB_B.GetImages(PicT.FileName) 320| 321| If TargetPicT Is Nothing Then 322| If DoScriptDebug Then Debug.Print " - ERROR! Couldn't add to TargetDB. Reason unknown." 323| If Reg.GetKey("DoLog") Then ProcBody = ProcBody & vbNewLine & " - ERROR! Couldn't add to TargetDB. Reason unknown." 324| ErrorCollection.CombineImage(PicT) 325| Else 326| 327| 'Action 2 328| If Reg.GetKey("transProp") Then 329| WD.SetLine3("... transmit Properties") 330| ActionResult = Trans.TransmitProperties(PicT, TargetPicT) 331| If DoScriptDebug Then Debug.Print " - transmit Properties = " & ActionResult 332| If Reg.GetKey("DoLog") Then ProcBody = ProcBody & vbNewLine & " - transmit Properties = " & ActionResult 333| End If 334| 335| 'Action 3 336| If Reg.GetKey("transCat") Then 337| WD.SetLine3("... transmit Categories") 338| ActionResult = Trans.TransmitCategories(PicT, TargetPicT) 339| If DoScriptDebug Then Debug.Print " - transmit Categories = " & ActionResult 340| If Reg.GetKey("DoLog") Then ProcBody = ProcBody & vbNewLine & " - transmit Categories = " & ActionResult 341| End If 342| 343| 'Action 4 344| TargetCollection.CombineImage(TargetPicT) 345| WD.AddFilesize(PicT.FileName) 346| 347| End If 348| 349| Else 350| 351| NotUpdated = NotUpdated +1 352| If DoScriptDebug Then Debug.Print " - is already in TargetDB. (No update wanted)" 353| If Reg.GetKey("DoLog") Then ProcBody = ProcBody & vbNewLine & " - is already in TargetDB. (No update wanted)" 354| 355| End If 356| 357| Else 358| 359| IsOffline = IsOffline +1 360| If DoScriptDebug Then Debug.Print " " & WD.ProcessSummary.procFiles & " SKIP OfflineImage: " & PicT.FileName 361| If Reg.GetKey("DoLog") Then ProcBody = ProcBody & vbNewLine & " " & WD.ProcessSummary.procFiles & " SKIP OfflineImage: " & PicT.FileName 362| 363| End If 364| 365| 366| 'refresh statusbar and waitdialog 367| WD.SetPercentage 368| If Application.WaitDialogIsCanceled Then 369| WD.SetLine3("PROCESS PAUSED BECAUSE CANCEL PRESSED BY USER") 370| ProcHeader = ProcHeader & vbNewLine & " Process paused: " & Now 371| If MsgBox(ProcHeader & vbNewLine & MakeProcFooter(WD.ProcessSummary.procFiles, WD.ProcessSummary.procTotalFilesize, Duration, StartTime) & vbNewLine & vbNewLine & vbNewLine & " - DO YOU REALLY WANT TO ABORT THIS PROCESS? -", vbYesNo, SCRIPTNAME & " " & ScriptVersionString) = vbYes Then Exit For 372| ProcHeader = ProcHeader & vbNewLine & " Process continued: " & Now 373| Application.WaitDialogClose 374| Application.WaitDialogOpen "", 0, Selection.Count, True 375| WD.SetLine3("PROCESS WILL CONTINUE NOW") 376| WD.SetPercentage 377| End If 378| 379| Next PicT 380| 381| If Not Application.WaitDialogIsCanceled Then ShowSummary = True 382| WD.Closes 383| WD.ClassUNSET 384| 385| 386| 'Sign all transmitted Images to an Import-Category in TargetDB 387| Dim Timestamp As String 388| Timestamp = "Date-" & Replace(CStr(Date),".","") & "_Time-" & Replace(CStr(Time),":","") 389| If TargetCollection.Count > 0 Then 390| If WD.ClassInit(TargetCollection.Count, "Assign Images to an ImportCategory in TargetDB") <> -1 Then 391| MsgBox "Couldn't initialize the WaitDialogClass!" & vbNewLine & vbNewLine & "Script stops now.", vbExclamation, SCRIPTNAME & " " & ScriptVersionString 392| GoTo Escape 393| End If 394| Set ParentImportCat = hn_AddCatToDB("_IMPORTED_IMAGES", DB_B) 395| Set ImportCat = hn_AddCatToDB(Timestamp, DB_B, ParentImportCat) 396| DB_B.Categories(ImportCat.FullName).AddImagesBucket(TargetCollection) 397| WD.Closes 398| WD.ClassUNSET 399| End If 400| 'Sign failed attempts to an ErrorCategory in SourceDB 401| If ErrorCollection.Count > 0 And Not DB_A.ReadOnly Then 402| Set ParentImportCat = hn_AddCatToDB("_EXPORT_ERRORS", DB_A) 403| Set ImportCat = hn_AddCatToDB(Timestamp, DB_A, ParentImportCat) 404| DB_A.Categories(ImportCat.FullName).AddImagesBucket(ErrorCollection) 405| End If 406| 407| 408| MakeProcFooter(WD.ProcessSummary.procFiles, WD.ProcessSummary.procTotalFilesize, Duration, StartTime) 409| If DoScriptDebug Then Debug.Print vbNewLine & ProcFooter 410| If Not DB_A Is Nothing Then DB_A.Redraw = True 411| If Not DB_B Is Nothing Then DB_B.Redraw = True 412| 413| End If 414| 415| 416| Escape: 417| If Not Reg Is Nothing Then 418| If Reg.GetKey("DoLog") Then SaveLog ProcHeader, ProcFooter, ProcBody 419| If ShowSummary Then MsgBox ProcFooter, vbInformation, SCRIPTNAME & " " & ScriptVersionString 420| End If 421| UNSET_OBJECTS 422| Exit Sub 423| 424| ErrHandler: 425| ErrMsg(Err) 426| Resume Escape 427| 428| End Sub 429| 430| 431| Public Sub UNSET_OBJECTS 432| FreeObject(WD) 433| FreeObject(Reg) 434| FreeObject(Trans) 435| FreeObject(DB_A) 436| FreeObject(DB_B) 437| FreeObject(Selection) 438| FreeObject(TargetPicT) 439| FreeObject(PicT) 440| FreeObject(OLCBuck) 441| FreeObject(TargetCollection) 442| FreeObject(ErrorCollection) 443| FreeObject(ImportCat) 444| FreeObject(ParentImportCat) 445| End Sub 446| 447| Private Function MakeProcFooter(ByRef curInt As Integer, ByRef TotalFileSize As Double, ByRef Duration As Double, ByRef StartTime As Double) As String 448| 449| On Error GoTo ErrHandler 450| 451| Duration = Timer - StartTime 452| If Duration < 0 Then Duration = Duration + 24.0*3600 453| 454| ProcFooter = vbNewLine & " Images treated (out of " & Selection.Count & "): " & CStr(curInt) 455| ProcFooter = ProcFooter & vbNewLine & " Images successful transmitted: " & CStr(TargetCollection.Count) & " (with total " & hn_friendlyBitStr(TotalFileSize) & " filesize)" 456| ProcFooter = ProcFooter & vbNewLine & " Images already exists in TargetDB: " & CStr(NotUpdated) 457| ProcFooter = ProcFooter & vbNewLine & " Images skipped, reason = offline: " & CStr(IsOffline) 458| ProcFooter = ProcFooter & vbNewLine & " Images has failed by attempt to add: " & CStr(ErrorCollection.Count) 459| ProcFooter = ProcFooter & vbNewLine & vbNewLine & "####### Transmission tooks " & hn_friendlyTimerStr(Duration) & " #####################" 460| 461| MakeProcFooter = ProcFooter 462| 463| Escape: 464| Exit Function 465| 466| ErrHandler: 467| ErrMsg(Err) 468| Resume Escape 469| 470| End Function 471| 472| 473| Private Function Dialog_initial() As Integer 474| 475| On Error GoTo ErrHandler 476| 477| Dim k As Integer 478| For k = 1 To Application.Databases.Count 479| ReDim Preserve dbList(0 To k) 480| dbList(k) = Application.Databases.Item(k).FileName 481| Next k 482| 483| Dim Title As String 484| Title = "Transmit Images from SourceDB to TargetDB " & ScriptVersionString 485| 486| Begin Dialog UserDialog 710,336,Title,.Dialog_Initial_Func ' %GRID:10,7,1,1 487| GroupBox 10,28,690,105,"Select Databases",.GroupBox1 488| DropListBox 30,63,650,98,dbList(),.DSource 489| DropListBox 30,105,650,98,dbList(),.DTarget 490| GroupBox 290,224,410,35,"Select Transmissions",.GroupBoxTrans 491| GroupBox 10,224,270,35,"",.GroupBoxTrans2 492| GroupBox 290,140,200,77,"SourceDB",.GroupBoxScope3 493| GroupBox 500,140,200,77,"TargetDB",.GroupBoxScope4 494| GroupBox 290,266,410,63,"",.GroupBox3 495| GroupBox 10,140,270,77,"Select Images-Scope of SourceDB",.GroupBoxScope 496| CancelButton 470,301,110,21,.CANCEL 497| OKButton 580,301,110,21,.OK 498| Text 30,49,650,14,"Select the Source-Database",.Text1 499| Text 30,91,650,14,"Select the Target-Database",.Text2 500| Text 310,154,170,56,"",.SourceText 501| Text 520,154,170,56,"",.TargetText 502| OptionGroup .GroupScope 503| OptionButton 30,175,240,14,"all Images",.ScopeAll 504| OptionButton 30,161,240,14,"only selected Images",.ScopeSelection 505| OptionButton 30,189,240,14,"safed ImageBucket",.ScopeSafedBucket 506| CheckBox 510,238,150,14,"transmit Properties",.DtransProp 507| CheckBox 310,238,150,14,"transmit Categories",.DtransCat 508| Text 300,280,390,14,"Warnings",.WarningText,2 509| Text 10,7,690,14,"MainWarning",.MainWarningText,2 510| PushButton 300,301,40,21,"File",.Btn_Logfile 511| Picture 10,273,270,56,MacroDir & "\icons\multidblogo.bmp",0,.Picture1 512| CheckBox 20,238,220,14,"! Overwrite Existing Records !",.DoverwriteExistingImages 513| CheckBox 350,301,110,21,"save Logfile",.DoLog 514| End Dialog 515| 516| Dim dlg As UserDialog 517| 'With this Script we cannot use the IPTC- and EXIF-Transmissions, because we only add the original Image 518| 'to another Database and IPTC- and Exif-Data are stored in the Image ;) 519| Reg.SaveKey("transIPTC",False,AsBoolean) 520| Reg.SaveKey("transEXIF",False,AsBoolean) 521| 522| With dlg 523| .GroupScope = Reg.GetKey("Scope",CInt(0)) 524| .DtransProp = Reg.GetKey("transProp",False) 525| .DtransCat = Reg.GetKey("transCat",False) 526| .DoverwriteExistingImages = Reg.GetKey("overwriteExistingImages", False) 527| .DoLog = Reg.GetKey("DoLog", False) 528| End With 529| 530| 531| Dialog_initial = Dialog(dlg) 532| If Dialog_initial <> -1 Then GoTo Escape 533| 534| 535| Reg.SaveKey("Scope",dlg.GroupScope,AsInteger) 536| Reg.SaveKey("transProp",dlg.DtransProp,AsBoolean) 537| Reg.SaveKey("transCat",dlg.DtransCat,AsBoolean) 538| Reg.SaveKey("DSource",dlg.DSource,AsInteger) 539| Reg.SaveKey("DTarget",dlg.DTarget,AsInteger) 540| Reg.SaveKey("overwriteExistingImages",dlg.DoverwriteExistingImages,AsBoolean) 541| Reg.SaveKey("DoLog",dlg.DoLog,AsBoolean) 542| 543| 544| Escape: 545| Exit Function 546| 547| ErrHandler: 548| ErrMsg(Err) 549| Resume Escape 550| 551| End Function 552| 553| Private Function Dialog_Initial_Func(DlgItem$, Action%, SuppValue&) As Boolean 554| 555| On Error GoTo ErrHandler 556| 557| Select Case Action% 558| Case 1 559| CheckDBintegrity 560| Case 2 561| Select Case DlgItem 562| Case "DtransProp", "DtransCat" 563| Reg.SaveKey("transProp",DlgValue("DtransProp"),AsBoolean) 564| Reg.SaveKey("transCat",DlgValue("DtransCat"),AsBoolean) 565| Dialog_Initial_Func = True 566| Case "CANCEL", "OK" 567| Dialog_Initial_Func = False 568| Case "DTarget", "DSource" 569| CheckDBintegrity 570| Dialog_Initial_Func = True 571| Case "Btn_Logfile" 572| Dim fo As FileStrObj 573| fo = hn_FileStrObject(Reg.GetKey("LogFileName", Environ("TEMP") & "\MDBTransmissionLOG.txt")) 574| Dim s As String 575| s = hn_BrowseForFile(NewAndExistingFiles, "Select a File, or a Folder and type in FileName to create a new one", "txt;log;rep", fo.FBasename, fo.PathWithDrive) 576| If s <> "" Then Reg.SaveKey("LogFileName",s) 577| Dialog_Initial_Func = True 578| End Select 579| End Select 580| 581| Escape: 582| Exit Function 583| 584| ErrHandler: 585| ErrMsg(Err) 586| Resume Escape 587| 588| End Function 589| 590| Private Function SourceText(ByRef Enabled As Boolean) As String 591| 592| On Error GoTo ErrHandler 593| 594| Dim s As String 595| Dim Icnt As Long, Ccnt As Long, Scnt As Long 596| Dim db1 As Database, db2 As Database 597| Set db1 = Application.Databases.Item(DlgValue("DSource")+1) 598| Set db2 = Application.Databases.Item(DlgValue("DTarget")+1) 599| 600| If Not db1 Is Nothing Then 601| If Not db1.GetImages Is Nothing Then Icnt = db1.GetImages.Count 602| If Not db1.Categories Is Nothing Then Ccnt = db1.Categories.Count 603| If Not db1.ActiveSelection Is Nothing Then Scnt = db1.ActiveSelection.Count 604| s = "- Total Cats: " & CStr(Ccnt) & vbNewLine & "- Total Images: " & CStr(Icnt) & vbNewLine & "- Selected Images: " & CStr(Scnt) 605| 606| If USE_BUCKETS_FOR_SELECTION Then 607| If hn_FileExists(BuildIBuckFileName(db1)) Then 608| Dim Ibuck As ImageBucket 609| Set Ibuck = db1.CreateImageBucket 610| 'Ibuck.Load(BuildIBuckFileName(db1)) 611| hn_BucketLoad(Ibuck, BuildIBuckFileName(db1), db1) 612| s = s & vbNewLine & "- Bucket Images: " & CStr(Ibuck.Count) 613| DlgEnable("ScopeSafedBucket",Enabled) 614| DlgText("ScopeSafedBucket", "safed Bucket " & CStr(Ibuck.Count)) 615| Set Ibuck = Nothing 616| Else 617| DlgEnable("ScopeSafedBucket",False) 618| DlgText("ScopeSafedBucket", "no safed Bucket available") 619| If DlgValue("GroupScope") = 2 Then DlgValue("GroupScope", 1) 620| End If 621| Else 622| DlgEnable("ScopeSafedBucket",False) 623| DlgText("ScopeSafedBucket", "BucketSelection not supported") 624| If DlgValue("GroupScope") = 2 Then DlgValue("GroupScope", 1) 625| End If 626| DlgText("SourceText", s) 627| DlgText("ScopeAll", "all " & CStr(Icnt) & " Images") 628| DlgText("ScopeSelection", "only " & CStr(Scnt) & " selected Images") 629| End If 630| 631| 632| Icnt = 0 633| Ccnt = 0 634| Scnt = 0 635| 636| 637| If Not db2 Is Nothing Then 638| If Not db2.GetImages Is Nothing Then Icnt = db2.GetImages.Count 639| If Not db2.Categories Is Nothing Then Ccnt = db2.Categories.Count 640| 'If Not db2.ActiveSelection Is Nothing Then Scnt = Application.Databases.Item(DlgValue("DTarget")+1).ActiveSelection.Count 641| s = "- Total Cats: " & CStr(Ccnt) & vbNewLine & "- Total Images: " & CStr(Icnt) 642| DlgText("TargetText", s) 643| End If 644| 645| 646| Escape: 647| If Not db1 Is Nothing Then Set db1 = Nothing 648| If Not db2 Is Nothing Then Set db2 = Nothing 649| Exit Function 650| 651| ErrHandler: 652| ErrMsg(Err) 653| Resume Escape 654| 655| End Function 656| 657| Private Function SetDlgItems(ByRef Enabled As Boolean, ByRef MainWarnText As String, ByRef WarnText As String) 658| 659| On Error GoTo ErrHandler 660| 661| DlgText("MainWarningText", MainWarnText) 662| DlgText("WarningText", WarnText) 663| DlgEnable("DtransProp", Enabled) 664| DlgEnable("DtransCat", Enabled) 665| DlgEnable("ScopeAll", Enabled) 666| DlgEnable("ScopeSelection", Enabled) 667| DlgEnable("ScopeSafedBucket",Enabled) 668| DlgEnable("Btn_Logfile", Enabled) 669| DlgEnable("DoLog", Enabled) 670| DlgEnable("OK", Enabled) 671| 672| Escape: 673| Exit Function 674| 675| ErrHandler: 676| ErrMsg(Err) 677| Resume Escape 678| 679| End Function 680| 681| 682| Private Sub CheckDBintegrity 683| 684| On Error GoTo ErrHandler 685| 686| Dim k As Integer, k2 As Integer 687| Dim CatsA As Categories, CatsB As Categories 688| Dim PropSetsA As PropertySets, PropSetsB As PropertySets 689| 690| If Not USE_BUCKETS_FOR_SELECTION Then 691| DlgEnable("ScopeSafedBucket",False) 692| DlgText("ScopeSafedBucket", "no safed Bucket available") 693| If DlgValue("GroupScope") = 2 Then DlgValue("GroupScope", 1) 694| End If 695| 696| If Application.Databases.Count < 2 Then 697| 698| DlgEnable("DSource",False) 699| DlgEnable("DTarget",False) 700| SetDlgItems(False, "Please open at least 2 (or more) Databases!", "You must specify different Databases for Source and Target!") 701| 702| Else 703| 704| If DlgValue("DSource") = DlgValue("DTarget") Then 705| 706| SetDlgItems(False, "You must specify different Databases for Source and Target!", "Please select 2 different Databases for Source and Target!") 707| SourceText(False) 708| 709| Else 710| 711| 712| If Application.Databases.Item(DlgValue("DTarget")+1).ReadOnly Then 713| 714| SetDlgItems(False, "Your TargetDB is opened in Read-Only-Mode. Please reopen in Write-Access-Mode first!", "Your TargetDB is opened in Read-Only-Mode!") 715| SourceText(False) 716| 717| Else 718| 719| Set CatsA = Application.Databases.Item(DlgValue("DSource")+1).Categories 720| Set CatsB = Application.Databases.Item(DlgValue("DTarget")+1).Categories 721| 722| 723| 'initialize statusbar and waitdialog 724| Dim MainWaitDialogText As String, CurFileText As String 725| Dim curInt As Integer, allInt As Integer 726| curInt = 0 727| allInt = CatsA.Count 728| MainWaitDialogText = "... comparing Databases. Please wait a moment ..." & vbNewLine 729| 'start statusbar and waitdialog 730| Application.StatusBarSetText MainWaitDialogText 731| Application.StatusBarShowPercentage 0, allInt 732| Application.WaitDialogOpen MainWaitDialogText, 0, allInt, True 733| 734| 735| If DoScriptDebug Then Debug.Print "######## Cats.Count " & CatsA.Count 736| For k = 1 To CatsA.Count 737| 738| 'refresh waitdialog 739| curInt = curInt +1 740| Application.WaitDialogSetText MainWaitDialogText & "- comparing Categories: " & curInt & "/" & allInt 741| 742| If Not CatsB.Item(CStr(CatsA.Item(k).FullName)) Is Nothing Then 743| If DoScriptDebug Then Debug.Print " - " & k & " " & CatsA.Item(k).FullName & " = " & CatsB.Item(CStr(CatsA.Item(k).FullName)).FullName 744| If CatsA.Item(k).FullName <> CatsB.Item(CStr(CatsA.Item(k).FullName)).FullName Then 745| SetDlgItems(False, "The CategoriesComparison has failed! Update your Target-DB.", "You must specify valid Databases for Source and Target!") 746| DlgEnable("Btn_CreateAllCats", True) 747| DlgText("Btn_CreateAllCats", "create TargetCats") 748| 'Reset statusbar and close waitdialog 749| Application.StatusBarHidePercentage 750| Application.WaitDialogClose 751| GoTo Escape 752| End If 753| Else 754| Debug.Print " - " & k & " (CategoriesComparison) Cat not found in Target-Database: " & CatsA.Item(k).FullName 755| SetDlgItems(False, "The CategoriesComparison has failed! Update your Target-DB.", "You must specify valid Databases for Source and Target!") 756| 'Reset statusbar and close waitdialog 757| Application.StatusBarHidePercentage 758| Application.WaitDialogClose 759| GoTo Escape 760| End If 761| 762| 'refresh statusbar and waitdialog 763| Application.StatusBarSetPercentage curInt 764| Application.WaitDialogSetPercentage curInt 765| If Application.WaitDialogIsCanceled Then 766| SetDlgItems(False, "The CategoriesComparison was canceld by user!", "You must specify valid Databases for Source and Target!") 767| 'Reset statusbar and close waitdialog 768| Application.StatusBarHidePercentage 769| Application.WaitDialogClose 770| GoTo Escape 771| End If 772| 773| Next k 774| 775| 'Reset statusbar and close waitdialog 776| Application.StatusBarHidePercentage 777| Application.WaitDialogClose 778| 779| 780| 781| Set PropSetsA = Application.Databases.Item(DlgValue("DSource")+1).PropertySets 782| Set PropSetsB = Application.Databases.Item(DlgValue("DTarget")+1).PropertySets 783| 784| 785| curInt = 0 786| allInt = PropSetsA.Count 787| MainWaitDialogText = "... comparing Databases. Please wait a moment ..." & vbNewLine 788| 'start statusbar and waitdialog 789| Application.StatusBarSetText MainWaitDialogText 790| Application.StatusBarShowPercentage 0, allInt 791| Application.WaitDialogOpen MainWaitDialogText, 0, allInt, True 792| 793| If DoScriptDebug Then Debug.Print "######## PropSets.Count " & PropSetsA.Count 794| For k = 1 To PropSetsA.Count 795| 796| 'refresh waitdialog 797| curInt = curInt +1 798| Application.WaitDialogSetText MainWaitDialogText & "- comparing Properties: " & curInt & "/" & allInt 799| 800| If DoScriptDebug Then Debug.Print " - " & k & " Set: " & PropSetsA.Item(k).Name 801| If PropSetsA.Item(k).Name <> PropSetsB.Item(k).Name Then 802| Debug.Print " - " & k & " (PropertySetsComparison) Set not found in Target-Database: " & PropSetsA.Item(k).Name 803| SetDlgItems(False, "The PropertiesComparison has failed! Update your Target-DB.", "You must specify valid Databases for Source and Target!") 804| 'Reset statusbar and close waitdialog 805| Application.StatusBarHidePercentage 806| Application.WaitDialogClose 807| GoTo Escape 808| Else 809| 810| If DoScriptDebug Then Debug.Print " " & " Properties.Count: " & PropSetsA.Item(k).Properties.Count 811| For k2 = 1 To PropSetsA.Item(k).Properties.Count 812| If DoScriptDebug Then Debug.Print " - " & k & "." & k2 & " Name: " & PropSetsA.Item(k).Properties(k2).Name & vbNewLine & " Type: " & PropSetsA.Item(k).Properties(k2).Type 813| If PropSetsA.Item(k).Properties(k2).Name <> PropSetsB.Item(k).Properties(k2).Name Or PropSetsA.Item(k).Properties(k2).Type <> PropSetsB.Item(k).Properties(k2).Type Then 814| Debug.Print " - " & k & " (PropertiesComparison) Property not found in Target-Database: " & PropSetsA.Item(k).Properties(k2).Name 815| SetDlgItems(False, "The PropertiesComparison has failed! Update your Target-DB.", "You must specify valid Databases for Source and Target!") 816| 'Reset statusbar and close waitdialog 817| Application.StatusBarHidePercentage 818| Application.WaitDialogClose 819| GoTo Escape 820| End If 821| Next k2 822| End If 823| 824| 'refresh statusbar and waitdialog 825| Application.StatusBarSetPercentage curInt 826| Application.WaitDialogSetPercentage curInt 827| If Application.WaitDialogIsCanceled Then 828| SetDlgItems(False, "The PropertiesComparison was canceld by user!", "You must specify valid Databases for Source and Target!") 829| 'Reset statusbar and close waitdialog 830| Application.StatusBarHidePercentage 831| Application.WaitDialogClose 832| GoTo Escape 833| End If 834| 835| Next k 836| 837| 'Reset statusbar and close waitdialog 838| Application.StatusBarHidePercentage 839| Application.WaitDialogClose 840| 841| SetDlgItems(True, "DB-Comparison successfull closed. Select the ImagesScope and Transmissions.", "") 842| SourceText(True) 843| 844| End If 845| 846| End If 847| 848| End If 849| 850| Escape: 851| FreeObject(PropSetsA) 852| FreeObject(PropSetsB) 853| FreeObject(CatsA) 854| FreeObject(CatsB) 855| Exit Sub 856| 857| ErrHandler: 858| ErrMsg(Err) 859| Resume Escape 860| 861| End Sub 862| 863| 864| Private Function BuildIBuckFileName(ByRef DB As Database) As String 865| 866| On Error GoTo ErrHandler 867| 868| If Not DB Is Nothing Then 869| BuildIBuckFileName = hn_BuildFolderStr(IBuckFilePath) & IBuckFileNamePrefix & CStr(DB.OID) & IBuckFileSuffix 870| Debug.Print "Filename = " & BuildIBuckFileName 871| Else 872| Debug.Print "No FilenameGeneration because we have no valid DB" 873| End If 874| 875| 876| Escape: 877| Exit Function 878| 879| ErrHandler: 880| ErrMsg(Err) 881| Resume Escape 882| 883| End Function 884| 885| 886| Private Function AddThisImageToDB(ByRef PicT As Image, ByRef TargetDB As Database, ByRef SourceDB As Database) As Boolean 887| 888| On Error GoTo ErrHandler 889| 890| Dim F As IMFolder 891| Set F = PicT.Folder 892| 893| If TargetDB.GetImages(PicT.FileName) Is Nothing Then 894| If Not F.Parent Is Nothing Then 895| Do 896| Set F = F.Parent 897| Loop While Not F.Parent Is Nothing 898| End If 899| If hn_AddImageToDB(PicT.FileName, TargetDB, F.Path) = imforSuccess Then AddThisImageToDB = True 900| Else 901| If Reg.GetKey("overwriteExistingImages") Then 902| If Not F.Parent Is Nothing Then 903| Do 904| Set F = F.Parent 905| Loop While Not F.Parent Is Nothing 906| End If 907| If hn_AddImageToDB(PicT.FileName, TargetDB, F.Path) = imforSuccess Then AddThisImageToDB = True 908| Else 909| AddThisImageToDB = False 910| End If 911| End If 912| 913| Escape: 914| FreeObject(F) 915| Exit Function 916| 917| ErrHandler: 918| ErrMsg(Err) 919| Resume Escape 920| 921| End Function 922| 923| 924| Private Function SaveLog(ByRef ProcHeader As String, ByRef ProcFooter As String, ByRef ProcBody As String) 925| 926| On Error GoTo ErrHandler 927| 928| If ProcFooter = "" Then ProcFooter = "The Script hasn't finished as expected." & vbNewLine & "There is no Process-Summary available!" 929| 930| Dim FN As Integer 931| FN = FreeFile 932| Open Reg.GetKey("LogFileName", Environ("TEMP") & "\MDBTransmissionLOG.txt") For Output As #FN 933| Print #FN, ProcHeader 934| Print #FN, " Process ended: " & Now 935| Print #FN, ProcFooter 936| Print #FN, vbNewLine & " - processed files:" 937| Print #FN, ProcBody & vbNewLine 938| Close #FN 939| 940| Escape: 941| Exit Function 942| 943| ErrHandler: 944| ErrMsg(Err) 945| Resume Escape 946| 947| End Function 948| 949| 950| 951|