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_PhotoshopConversion.bas
Needed Modules: [hnFncPSOLE.lib]
[hnFncUtils.lib]
[hnClsRegKey.cls]
[hnPSoleDeclarations.lib]
[hnPublicDeclarations.lib]
hnFncUtils.lib: (2073 lines / 1311 real codelines / 2 Subs / 48 Functions / 0 Properties)
1| '#Reference {5BAA3B30-7D07-46D2-948A-1551CBFD2BB4}#1.0#0#P:\IMatch\IMatchADT.dll#IMatch 3 Scripting Helper 1.0 Type Library 2| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 3| ' 4| 5| ' 6| ' h.nogajski@web.de 7| ' http://horst.nogajski.de 8| ' 9| '-------------------------------------------------------------------------------------------------- 10| ' 11| ' Utils (for IMatch SAX-Basic or VBA) 12| ' 13| ' Collection of useful Functions 14| ' All Functions beginnig with hn_ are mine, all others I've 'found' ;-) 15| ' 16| ' 17| 'V 1.4 (28-Jun-2003) 18| ' 19| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 20| '-------------------------------------------------------------------------------------------------- 21| ' 22| ' Uses / Embedds 23| ' 24| ' This Script itself needs the IMatch 3 Scripthelping Type Library 25| ' and the Microsoft Scripting Runtime Library embedded 26| ' (check Edit->References in Sax-Basic-Editor) 27| ' 28| ' 29| '#uses "hnPublicDeclarations.lib" 30| '#uses "hnClsSysInfo.cls" 31| ' 32| '-------------------------------------------------------------------------------------------------- 33| ' 34| ' Public Functions: 35| ' 36| ' ------------------------------------------------------------------------------------------- 37| ' CheckVersionAgainst (with LibFileName-Prefix) => hnFncUtilsLibCheckVersionAgainst 38| ' Descript: Checks a given Long against the LibVersionNumber. 39| ' The given Long represents the LibVersionNumber which the 40| ' script-author has used creating his script. 41| ' Params: Long neededLong, Optional Boolean suppressMsgBox 42| ' Returns: Boolean 43| ' ------------------------------------------------------------------------------------------- 44| ' ShellAndWait 45| ' Starts a ShellProcess and waits with Scriptexecution until the Process has terminated. 46| ' hn_FileExists 47| ' Returns True if file exists. Needs absolute Path-/Filename. 48| ' hn_BuildFolderStr 49| ' Concatenates a mainfolderstring and subfolderstring to a valid PathString 50| ' hn_MkDir 51| ' Creates new Directory/s. On Failure it returns an ErrorString. 52| ' Works only with absolute Pathes. But with Local- and UNC-Pathes! :) 53| ' hn_CalculateUplinks 54| ' Resolve Strings with Uplinks to absolute PathStrings :) 55| ' hn_AppendNextFreeNumberToFN 56| ' Check if a File already exists and if so, append next free Number to the FileNameString. 57| ' hn_FileStrObject 58| ' Checks a Filename-String and returns the Drive, Path, Basename, Type etc. as FileStrObj 59| ' hn_Xdel 60| ' Deletes all Files of a given Foldername incl. Subfolders via ShellCommand. 61| ' hn_Xdel2 62| ' Deletes all Files of a given Foldername incl. Subfolders within IMatch. Provides Database-Update. 63| ' AppendStringToFilename 64| ' Appends a given String to a Filename before the ".typ": filename.typ + _string = filename_string.typ 65| ' RemoveStringFromFilename 66| ' Removes a given String from a Filename and returns the resulting Filename: filename_string.typ - _string = filename.typ 67| ' DoReplaceStr 68| ' Replace a SubString in String with a ReplacementString 69| ' SortStringArray 70| ' Sorts a StringArray by Reference. 71| ' IsValidStrArray 72| ' Checks if an Array is a StringArray. Returns True or False. 73| ' ReadListFromFile 74| ' Reads a textfile into a StringArray where each Item is seperated by a LF. 75| ' WriteListToFile 76| ' Writes a StringArray into a textfile where each Item is seperated by a LF. 77| ' createURLShortCut 78| ' Creates an InternetShortCutFile. 79| ' Needs the absolute URL incl. Protocol, host and Path, and optional a filename (only the basename, e.g. filename.url) for the InternetShortCutfile. 80| ' Returns a Fullpathfilename which can be loaded with Application.ShellExecute("open",filename) 81| ' hn_BrowseForFile 82| ' Opens a SelectFile(name)-DialogBox 83| ' hn_friendlyTimerStr 84| ' Returns a String instead of a Double: 0,105 sec; 20,324 sec; 5 min; 2 hours; 85| ' hn_friendlyFilesizeStr 86| ' Returns a String with the filesize: 1 k; 342 k; 7,5 MB; 1,2 GB; etc. / needs a FullPath to File 87| ' hn_friendlyBitStr 88| ' Returns a String with filesize from a given Double: 1 k; 342 k; 7,5 MB; 1,2 GB; etc. 89| ' hn_AddImageToDB 90| ' WrapperClass for older Scripts (prior 3.3.0.4) Mario has changed the behavior of this method 91| ' hn_AddFolderToDB 92| ' needed also for the hn_AddImageToDB-Function 93| ' hn_AddCatToDB 94| ' 95| ' hn_BucketLoad 96| ' IMatch Version 3.3.0.6 has a Bug, this is a workaround until a patch will released where this is fixed! 97| ' hn_BucketSafe 98| ' IMatch Version 3.3.0.6 has a Bug, this is a workaround until a patch will released where this is fixed! 99| ' BookmarksOn 100| ' Sets all Booksmarks for the active Selection _ON_, and do not toggle the Offs to On and the Ons to Off ;) 101| ' (used in OneclickBar and ScriptContextMenu) 102| ' BookmarksOff 103| ' Sets all Booksmarks for the active Selection _OFF_, and do not toggle the Offs to On and the Ons to Off ;) 104| ' (used in OneclickBar and ScriptContextMenu) 105| ' RemoveAllBookmarks 106| ' Deletes all Bookmarks of the active DB 107| ' (used in OneclickBar) 108| ' hn_lcmsConversion 109| ' Input: Fullpathfilename of any Imagetype, but it can only work with Tiffs and Jpegs! 110| ' (with embedded ICC-Profile or specified input-iccfile, and/or output-iccfile) 111| ' Output: On Success for jpegs and tiffs = Fullpathfilename of converted temporary file 112| ' On failure for jpegs and tiffs = Fullpathfilename of sourcefile 113| ' For unsupported filetypes = Fullpathfilename of sourcefile 114| ' 115| '-------------------------------------------------------------------------------------------------- 116| ' 117| ' Constants: 118| ' 119| ' LibVersion and LibVersionString 120| ' Holds the revision Version of this Lib as Long, 121| ' to allow testing for downward compatibility. 122| ' Two digits per position, allows for versions such as V 20.12.29 123| ' Last position not used in String now, 124| ' (could be used for internal releases for example), set to 00 in Long! 125| ' 126| ' SCRIPTNAME 127| ' Is needed for LibName, in MsgBoxTitles, etc. 128| ' 129| '-------------------------------------------------------------------------------------------------- 130| ' 131| ' VersionChanges: 132| ' 133| ' V 1.0 (01-Nov-2002) initial release 134| ' 135| ' V 1.02 (03-Mar-2003) added: hn_friendlyTimerStr; hn_BrowseForFile; hn_ValidateStr; 136| ' DoReplaceStr; 137| ' V 1.03 (01-Apr-2003) added: LibVersion; hnFncUtilsLibCheckVersionAgainst; 138| ' 139| ' V 1.04 (12-Apr-2003) added: BookmarksOn; BookmarksOff; RemoveAllBookmarks; 140| ' (used mainly in OneclickBar and ScriptContextMenu) 141| ' V 1.1 (30-May-2003) added: hn_BrowseForFile; hn_BuildOfflineCacheFilenameStr; hn_CalculateUplinks; 142| ' hn_friendlyBitStr; hn_friendlyFilesizeStr; hn_friendlyTimerStr; 143| ' pow; hn_SetListBoxByStrVal; hn_AddImageToDB; hn_AddFolderToDB; 144| ' hn_AddCatToDB; hn_BucketLoad; hn_BucketSafe; 145| ' V 1.2 (24-Jun-2003) added: GetWinHandleByName; WinTransparentSet; WinTransparentUnset; 146| ' minor Bugfix for hn_AppendNextFreeNumberToFN; 147| ' V 1.3 (25-Jun-2003) added: hn_lcmsConversion 148| ' 149| ' V 1.4 (28-Jun-2003) added: hn_BuildOfflineCacheFolderStr; hn_KillFile; hn_DirIntoArray; 150| ' changed: hn_BuildOfflineCacheFilenameStr 151| ' 152| '-------------------------------------------------------------------------------------------------- 153| '|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| 154| 155| 156| 157| Option Explicit 158| 159| 160| 'LibVersion 161| Private Const LibVersionString As String = "V 1.4 (28-Jun-2003)" 162| Private Const LibVersion As Long = 14000 163| 'SCRIPTNAME 164| Private Const SCRIPTNAME As String = "hnLibUtilsPublic" 165| 166| 167| 168| Public Function hnFncUtilsLibCheckVersionAgainst(ByRef neededLong As Long, Optional ByRef suppressMsgBox As Boolean = False) As Boolean 169| If neededLong <= LibVersion Then 170| hnFncUtilsLibCheckVersionAgainst = True 171| Else 172| hnFncUtilsLibCheckVersionAgainst = False 173| If Not suppressMsgBox Then 174| MsgBox "The version of the " & SCRIPTNAME & " is to old: " & LibVersionString & " = long(" & LibVersion & ")" & vbNewLine & vbNewLine & _ 175| "Maybe that you have overwritten the file contained in the ZIP file of this Script" & vbNewLine & _ 176| "with an outdated version delivered with another script in your Script folder." & vbNewLine & vbNewLine & _ 177| "Please check and reinstall the file from the ZIP file of this Script" & vbNewLine & _ 178| "with version: long(" & CStr(neededLong) & "), or greater.", vbInformation,"Outdated Classfile: " & SCRIPTNAME 179| End If 180| End If 181| End Function 182| 183| 184| Public Function ShellAndWait(ByVal ExeFullPath As String, Optional TimeOutValue As Long = 0, Optional SetWindowStyle As ShellWindowStyle = vbNormalFocus) As Boolean 185| 186| On Error GoTo ErrHandler 187| 188| Dim lInst As Long 189| Dim lStart As Long 190| Dim lTimeToQuit As Long 191| Dim sExeName As String 192| Dim lProcessId As Long 193| Dim lExitCode As Long 194| Dim bPastMidnight As Boolean 195| 196| lStart = CLng(Timer) 197| sExeName = ExeFullPath 198| 199| 'Deal with timeout being reset at Midnight 200| If TimeOutValue > 0 Then 201| If lStart + TimeOutValue < 86400 Then 202| lTimeToQuit = lStart + TimeOutValue 203| Else 204| lTimeToQuit = (lStart - 86400) + TimeOutValue 205| bPastMidnight = True 206| End If 207| End If 208| 209| lInst = Shell(sExeName, SetWindowStyle) 210| 211| lProcessId = OpenProcess(PROCESS_QUERY_INFORMATION, False, lInst) 212| 213| Do 214| Call GetExitCodeProcess(lProcessId, lExitCode) 215| DoEvents 216| If TimeOutValue And Timer > lTimeToQuit Then 217| If bPastMidnight Then 218| If Timer < lStart Then Exit Do 219| Else 220| Exit Do 221| End If 222| End If 223| Loop While lExitCode = STATUS_PENDING 224| 225| ShellAndWait = True 226| 227| Escape: 228| Exit Function 229| 230| ErrHandler: 231| ErrMsg(Err) 232| Resume Escape 233| 234| End Function 235| 236| 237| Public Function hn_BrowseForFile(ByVal BoxType As BrowseForFileBox, Optional ByVal BoxTitle As String = "browse for file", Optional ByVal Extensions As String = "*", Optional ByVal Defaultname As String = "", Optional ByVal StartDir As String) As String 238| 'Opens the Browse For File Dialog, Extensions must give as a semicolon-separated string without dots and Wildcarts: "txt;doc;jpeg;gif;png" if you leave blank AllFiles are set "*" 239| 'If you wants the user have to search for a specificfilename set it as Defaultname 240| 'The SAX-Basic Engine has a little bug, it cuts the last Char of the Defaultname-String, so we add a space for that. 241| 242| On Error GoTo Errhandler 243| 244| If BoxType > 2 Or BoxType < 0 Then BoxType = NewAndExistingFiles 245| hn_BrowseForFile = GetFilePath$(Defaultname & " ", Extensions, StartDir, BoxTitle, BoxType) 246| 247| Escape: 248| Exit Function 249| 250| ErrHandler: 251| ErrMsg(Err) 252| Resume Escape 253| 254| End Function 255| 256| 257| Public Function hn_FileExists(ByVal FullpathFileName As String, Optional DirAttr As DirParams = vbNormal) As Boolean 258| 259| On Error GoTo Errhandler 260| 'Dim origAttr As Integer 261| 'origAttr = GetAttr(FullpathFileName) 262| 'SetAttr FullpathFileName, 0 263| If Len(Dir(FullpathFileName,DirAttr)) <> 0 Then hn_FileExists = True 264| 'SetAttr FullpathFileName, origAttr 265| Escape: 266| Exit Function 267| 268| ErrHandler: 269| ErrMsg(Err) 270| Resume Escape 271| 272| End Function 273| 274| 275| Public Function hn_KillFile(ByVal FullpathFileName As String, Optional ByVal DoSimulation As Boolean = False) As Boolean 276| 277| On Error GoTo Errhandler 278| 279| If DoSimulation Then 280| Debug.Print "- hn_KillFile-Simulation: " & FullpathFileName 281| hn_KillFile = True 282| Else 283| 284| If hn_FileExists(FullpathFileName) Then 285| SetAttr FullpathFileName, 0 286| Kill FullpathFileName 287| End If 288| 289| If Not hn_FileExists(FullpathFileName) Then hn_KillFile = True 290| 291| End If 292| 293| Escape: 294| Exit Function 295| 296| ErrHandler: 297| ErrMsg(Err) 298| Resume Escape 299| 300| End Function 301| 302| 303| Public Function hn_Xdel(ByVal FullPathFolder As String) 304| 305| On Error GoTo Errhandler 306| 307| If Right(FullPathFolder,1) <> "\" Then FullPathFolder = FullPathFolder & "\" 308| FullPathFolder = FullPathFolder & "*.*" 309| 310| Dim deleteAll As Variant 311| deleteAll = ShellAndWait(Environ("COMSPEC") & " /C " & "del " & FullPathFolder & " /F /S /Q",,vbNormalNoFocus) 312| 313| Escape: 314| Exit Function 315| 316| ErrHandler: 317| ErrMsg(Err) 318| Resume Escape 319| 320| End Function 321| 322| 323| 324| Public Function hn_Xdel_IMFolder(ByVal FullPathFolder As String, ByVal DB As Database, Optional ByVal DoDebugPrint As Boolean = False) As String 325| 326| On Error GoTo Errhandler 327| 328| Dim p As String 329| p = FullPathFolder 330| If Right(p,1) <> "\" Then p = p & "\" 331| Dim f As IMFolder 332| Set f = DB.Folders(p) 333| If DoDebugPrint Then Debug.Print "- Proceed: " & p 334| 335| 336| ' First scan the files in the folder 337| Dim fname As String 338| fname = Dir(p & "*.*",vbNormal) 339| While fname <> "" 340| SetAttr(p & fname,vbArchive) 341| If DoDebugPrint Then Debug.Print " Kill: " & p & fname 342| On Error Resume Next 343| Kill p & fname 344| If Err.Number <> 0 And Not Err.Number = 10101 Then 345| MsgBox Err.Number & vbNewLine & Err.Description 346| Resume Escape 347| ElseIf Err.Number = 10101 Then 348| Resume Next 349| Err.Clear 350| On Error GoTo Errhandler 351| If DoDebugPrint Then Debug.Print "- ERROR: Kill was not succesfull - " & p & fname 352| End If 353| If Not f Is Nothing Then Application.UpdateDatabase(p & fname,True) 354| fname = Dir() 355| Wend 356| 357| ' Check for sub-directories 358| ' Note: We need to store the names found in a collection, 359| ' because the Dir function does not allow recursive calls! 360| Dim dirs As New IMCollection 361| 362| fname = Dir(p & "*.*",vbDirectory) 363| While fname <> "" 364| If (GetAttr(p & fname) And vbDirectory) = vbDirectory Then 365| If Left(fname,1) <> "." Then 366| dirs.Add p & fname 367| If DoDebugPrint Then Debug.Print "- Found SubDir: " & p & fname 368| End If 369| End If 370| fname = Dir() 371| Wend 372| 373| Dim d As Variant 374| For Each d In dirs 375| hn_Xdel_IMFolder(d,DB,DoDebugPrint) 376| Next d 377| 378| 'Wichtig: das Objekt wieder frei geben. 379| 380| Set dirs = Nothing 381| 382| 'Delete the ParentFolder itself 383| DB.RemoveFolder(f,False) 384| SetAttr(FullPathFolder,vbArchive) 385| If DoDebugPrint Then Debug.Print " Deleting Folder: " & FullPathFolder 386| On Error Resume Next 387| RmDir(FullPathFolder) 388| If Err.Number <> 0 And Not Err.Number = 10104 Then 389| MsgBox Err.Number & vbNewLine & Err.Description 390| Resume Escape 391| ElseIf Err.Number = 10104 Then 392| Resume Next 393| Err.Clear 394| On Error GoTo Errhandler 395| If DoDebugPrint Then Debug.Print "- ERROR: Deleting not succesfull - " & FullPathFolder 396| End If 397| 398| Escape: 399| Exit Function 400| 401| ErrHandler: 402| ErrMsg(Err) 403| Resume Escape 404| 405| End Function 406| 407| 408| Public Function hn_debugPrintArray(ByRef A() As String) 409| 410| On Error GoTo ErrHandler 411| 412| Dim k As Integer 413| For k = LBound(A) To UBound(A) 414| Debug.Print A(k) 415| Next 416| 417| Escape: 418| Exit Function 419| 420| ErrHandler: 421| ErrMsg(Err) 422| Resume Escape 423| 424| End Function 425| 426| Public Function hn_CalculateUplinks(ByVal PathStr As String, Optional ByRef doDebug As Boolean = False) As String 427| 428| On Error GoTo ErrHandler 429| 430| Dim x As FileStrObj 431| Dim PathSegments() As String 432| Dim NewP As String 433| Dim finished As Boolean 434| Dim SegID As Integer, k As Integer, UpLinks As Integer, ups As Integer 435| 436| 437| 'Debugging 438| If doDebug Then Debug.Print " ----------------------------------" & vbNewLine & " hn_CalculateUplinks: Pathstr=" & PathStr 439| 440| x = hn_FileStrObject(PathStr) 441| PathSegments() = Split(x.PathNoDrive, "\") 442| For k = LBound(PathSegments) To UBound(PathSegments) 443| If PathSegments(k) = ".." Then UpLinks = UpLinks +1 444| Next k 445| SegID = UBound(PathSegments) 446| 447| 'Debugging 448| If doDebug Then 449| 'Debug.Print " PathString without drive and filename: " & x.PathNoDrive 450| Debug.Print " counted Segments: " & SegID 451| Debug.Print " counted UpLinks: " & UpLinks 452| hn_debugPrintArray(PathSegments()) 453| End If 454| 455| 456| If UpLinks > 0 Then 457| 458| If PathSegments(0) = ".." Then 459| MsgBox "Error: Bad Uplink!" & vbNewLine & vbNewLine & "The given PathString has an Uplink wich refers higher than Root :(" & vbNewLine & PathStr 460| GoTo UplinkError 461| ElseIf (UpLinks * 2)> SegID Then 462| MsgBox "Error: Bad Uplinks!" & vbNewLine & vbNewLine & "The given PathString contains to many UpLinks :(" & vbNewLine & PathStr 463| GoTo UplinkError 464| End If 465| 466| 467| k = SegID 468| Do Until k = -1 469| 470| If k < 0 Then 471| Dim BadStr As String 472| For SegID = k To -2 473| BadStr = BadStr & "\.." 474| Next 475| MsgBox "Error: Bad Uplink!" & vbNewLine & vbNewLine & "The given PathString has Uplinks wich refers higher than Root :(" & vbNewLine & _ 476| "SourceString: " & PathStr & vbNewLine & "Calculated: " & x.Drive & BadStr & NewP & x.FBasename 477| GoTo UplinkError 478| End If 479| 480| ups = 0 481| finished = False 482| 483| 'Debugging 484| If doDebug Then Debug.Print " - check Segment number " & k & " (" & PathSegments(k) & ")" 485| 486| Do 487| If PathSegments(k - ups) = ".." Then 488| 'Debugging 489| If doDebug Then Debug.Print " - is UpLink: " & k - ups 490| ups = ups + 1 491| Else 492| 'Debugging 493| If doDebug Then Debug.Print " - is valid: " & k - ups 494| finished = True 495| End If 496| Loop While Not finished 497| 498| 499| 'Debugging 500| If doDebug Then Debug.Print " - counted ups: " & ups 501| 502| k = k - (2 * ups) 503| 504| 505| If k > -1 Then 506| If PathSegments(k) <> ".." Then 507| 'Debugging 508| If doDebug Then Debug.Print " - NewP = " & Chr(34) & "\" & Chr(34) & " & " & PathSegments(k) & " & " & NewP & " = " & "\" & PathSegments(k) & NewP 509| NewP = "\" & PathSegments(k) & NewP 510| k = k -1 511| End If 512| End If 513| Loop 514| 515| Else 516| If Len(x.PathNoDrive) > 1 Then 517| NewP = "\" & x.PathNoDrive 518| Else 519| NewP = x.PathNoDrive 520| End If 521| End If 522| 523| 524| hn_CalculateUplinks = x.Drive & NewP & x.FBasename 525| 'Debugging 526| If doDebug Then Debug.Print vbNewLine & " hn_CalculateUplinks RETURNS: " & hn_CalculateUplinks & vbNewLine & " ----------------------------------" 527| 528| Escape: 529| Exit Function 530| 531| ErrHandler: 532| ErrMsg(Err) 533| Resume Escape 534| 535| UplinkError: 536| hn_CalculateUplinks = "" 537| 538| End Function 539| 540| 541| Public Function hn_BuildFolderStr(ByVal Mainfolder As String, Optional ByVal Subfolder As String, Optional ByVal ReCalculateUplinks As Boolean = True, Optional ByRef doDebug As Boolean = False) As String 542| 543| On Error GoTo ErrHandler 544| 545| If doDebug Then Debug.Print "hn_BuildFolderStr: Mainfolder=" & Mainfolder & " | Subfolder=" & Subfolder & " | ReCalculateUplinks=" & CStr(ReCalculateUplinks) 546| If Right(Mainfolder,1) <> "\" Then Mainfolder = Mainfolder & "\" 547| 548| If Subfolder <> "" Then 549| If Right(Subfolder,1) <> "\" Then Subfolder = Subfolder & "\" 550| If Left(Subfolder,1) = "\" Then Subfolder = Mid$(Subfolder,2,Len(Subfolder)-1) 551| End If 552| 553| hn_BuildFolderStr = Mainfolder & Subfolder 554| 555| 'If there are ..\ (uplinks) in the PathString, we can recalculate it to get a direct, absolute PathString. 556| If ReCalculateUplinks Then hn_BuildFolderStr = hn_CalculateUplinks(hn_BuildFolderStr, doDebug) 557| If doDebug Then Debug.Print "hn_BuildFolderStr RETURNS: " & hn_BuildFolderStr 558| 559| 560| Escape: 561| Exit Function 562| 563| ErrHandler: 564| ErrMsg(Err) 565| Resume Escape 566| 567| End Function 568| 569| 570| Private Function hn_SplitPathStr(ByVal TheLongDirName As String) As PathStrObj 571| 572| On Error GoTo ErrHandler 573| 574| Dim DT As DT, TheDrive As String, PathNoDrive As String 575| 576| 577| If Right(TheLongDirName,1) <> "\" Then TheLongDirName = TheLongDirName & "\" 578| TheLongDirName = Left(TheLongDirName,Len(TheLongDirName)-1) 579| 580| 'Check for Drivepart in given String 581| If Mid$(TheLongDirName,2,1) = ":" Then 582| 'We 've got an absolute Path with Driveletter 583| TheDrive = Left(TheLongDirName,2) 584| If Len(TheLongDirName) > 3 Then 585| PathNoDrive = Mid$(TheLongDirName,4,CInt(Len(TheLongDirName) - 3)) 586| Else 587| PathNoDrive = "" 588| End If 589| DT = Local 590| ElseIf Mid$(TheLongDirName,1,2) = "\\" Then 591| 'We 've got an UNC-Path 592| If InStr(3,TheLongDirName,"\") <> 0 Then 593| TheDrive = Left$(TheLongDirName,CInt(InStr(3,TheLongDirName,"\")-1)) 594| PathNoDrive = Mid$(TheLongDirName,CInt(Len(TheDrive)+2),CInt(Len(TheLongDirName) - Len(TheDrive) -1)) 595| Else 596| TheDrive = Left$(TheLongDirName,Len(TheLongDirName)-2) 597| PathNoDrive = "" 'geht eigentlich nicht! 598| End If 599| DT = UNC 600| ElseIf Left$(TheLongDirName,1) = "\" And Left$(TheLongDirName,2) <> "\" Then 601| 'We 've got the Root of CurrentWorkingDrive (?) 602| TheDrive = Left$(CurDir,2) 603| PathNoDrive = Mid$(Left$(CurDir,2) & TheLongDirName,4,CInt(Len(TheLongDirName) - 1)) 604| TheLongDirName = TheDrive & "\" & PathNoDrive 605| DT = Local 606| Else 607| 'Error. No valid PathString. 608| GoTo Escape 609| End If 610| 611| hn_SplitPathStr.DType = DT 612| hn_SplitPathStr.DName = TheDrive 613| hn_SplitPathStr.PathNoDrive = PathNoDrive 614| 615| 616| Escape: 617| Exit Function 618| 619| ErrHandler: 620| ErrMsg(Err) 621| Resume Escape 622| 623| End Function 624| 625| 626| Public Function hn_FileStrObject(ByVal fname As String) As FileStrObj 627| 628| On Error GoTo ErrHandler 629| 630| Dim p As String, n As String, t As String, n2 As String 631| Dim dStr As PathStrObj 632| 633| 634| If Right(fname,1) = "\" Or InStrRev(fname,".") = 0 Then 635| 'We have no File with Filetype. Seems to be a Directory 636| n2 = "" 637| t = "" 638| p = fname 639| 640| Else 641| 'Seems to be a File 642| If InStrRev(fname,".") <> 0 Then 643| n = Left(fname,InStrRev(fname,".")-1) 644| t = Right(fname,Len(fname) - InStrRev(fname,".")) 645| Else 646| n = fname 647| t = "" 648| End If 649| 650| If InStrRev(n,"\") <> 0 Then 651| n2 = Right(n,Len(n) - InStrRev(n,"\")) 652| p = Left(n,Len(n) - Len(n2)) 653| Else 654| n2 = n 655| p = "" 656| End If 657| 658| End If 659| 660| dStr = hn_SplitPathStr(p) 661| 662| If dStr.DName <> "" Then 663| hn_FileStrObject.ValidPathStr = True 664| End If 665| hn_FileStrObject.UNC_Path = CBool(dStr.DType) 666| hn_FileStrObject.Drive = dStr.DName 667| 668| 669| hn_FileStrObject.PathFull = fname 670| hn_FileStrObject.PathWithDrive = p 671| 672| If Right(dStr.PathNoDrive,1) <> "\" Then dStr.PathNoDrive = dStr.PathNoDrive & "\" 673| hn_FileStrObject.PathNoDrive = dStr.PathNoDrive 674| 675| 676| If n2 <> "" Then 677| hn_FileStrObject.FBasename = n2 678| End If 679| If t <> "" Then 680| hn_FileStrObject.FBasename = n2 & "." & t 681| End If 682| hn_FileStrObject.FName = n2 683| hn_FileStrObject.FType = t 684| 685| Escape: 686| Exit Function 687| 688| ErrHandler: 689| ErrMsg(Err) 690| Resume Escape 691| 692| End Function 693| 694| 695| Public Function hn_MkDir(ByVal TheLongDirName As String) As String 696| 'Works only with absolute locale-Pathes (C:\dir\subdir) or with UNC-Pathes (\\station\source\subdir), NOT with relative Pathes! 697| 698| On Error GoTo ErrHandler 699| 700| Dim PathStr As PathStrObj 701| Dim cwd As String 702| Dim PathSegments() As String, segID As Integer 703| hn_MkDir = "Try to create Directory: " & TheLongDirName 704| 705| PathStr = hn_SplitPathStr(TheLongDirName) 706| 707| If Len(Dir(TheLongDirName,vbDirectory)) = 0 Then 708| 'The Targetdirectory does not exist 709| cwd = PathStr.DName 710| PathSegments() = Split(PathStr.PathNoDrive, "\") 711| For segID = LBound(PathSegments) To UBound(PathSegments) 712| cwd = cwd & "\" & PathSegments(segID) 713| On Error Resume Next 714| MkDir(cwd) 715| Next 716| 717| On Error GoTo ErrHandler 718| 719| If Len(Dir(TheLongDirName,vbDirectory)) <> 0 Then 720| hn_MkDir = "" 721| Else 722| hn_MkDir = "MkDir Directory (" & TheLongDirName & ") has failed!" 723| End If 724| 725| Else 726| 727| 'The Targetdirectory exists 728| hn_MkDir = "" 729| 730| End If 731| 732| Escape: 733| Exit Function 734| 735| ErrHandler: 736| hn_MkDir = ErrMsg(Err) 737| Resume Escape 738| 739| End Function 740| 741| 742| Public Function hn_AppendNextFreeNumberToFN(ByVal filename As String) As String 743| 744| On Error GoTo ErrHandler 745| 746| Dim AddI As Integer 747| hn_AppendNextFreeNumberToFN = filename 748| If hn_FileExists(hn_AppendNextFreeNumberToFN) Then 749| Do 750| AddI = AddI + 1 751| hn_AppendNextFreeNumberToFN = AppendStringToFilename(filename, Chr(95) & Chr(40) & CStr(AddI) & Chr(41)) 752| Loop Until Not hn_FileExists(hn_AppendNextFreeNumberToFN,vbNormal) 753| End If 754| 755| Escape: 756| Exit Function 757| 758| ErrHandler: 759| ErrMsg(Err) 760| Resume Escape 761| 762| End Function 763| 764| 765| 766| Public Function AppendStringToFilename(ByVal fname As String, ByVal appstr As String) As String 767| 768| Dim s As String, sf As String 769| 'sf = "." & DOC.TargetFileFormat 770| 771| If InStrRev(fname,".") <> 0 Then 772| s = Left(fname,InStrRev(fname,".")-1) 773| sf = Right(fname,Len(fname) - InStrRev(fname,".")+1) 774| AppendStringToFilename = s & appstr & sf 775| Else 776| AppendStringToFilename = fname & sf 777| End If 778| 779| End Function 780| 781| 782| Public Function RemoveStringFromFilename(fname As String) As String 783| 784| Dim k As Integer 785| k = InStrRev(fname,".") 786| If k>0 Then 787| RemoveStringFromFilename = Left(fname,k-1) 788| Else 789| RemoveStringFromFilename = fname 790| End If 791| 792| End Function 793| 794| 795| Public Sub SortStringArray(ByRef A() As String) 796| Dim t As String 797| Dim i As Long 798| Dim j As Long 799| 800| For i = LBound(A) To UBound(A) 801| For j = i + 1 To UBound(A) 802| If A(i) > A(j) Then 803| t = A(i) 804| A(i) = A(j) 805| A(j) = t 806| End If 807| Next 808| Next 809| 810| End Sub 811| 812| 813| Public Function ReadListFromFile(ByRef FileName As String) As String() 814| 'reads a text file where each Item is seperated by a LF 815| 816| Dim s As String 817| Dim temp() As String 818| Dim res() As String 819| Dim k As Integer,j As Integer 820| 821| 'PS_ReadICCList = 822| s = Trim$(GetTextFromFile(FileName)) 823| If s = "" Then Exit Function 824| temp = Split(s,Chr(10)) 825| ReDim res(UBound(temp)) 826| 827| For k=0 To UBound(temp) 828| s = temp(k) 829| s = Replace(s,Chr(10),"",1,-1)'remove LF, CR etc 830| s = Replace(s,Chr(13),"",1,-1) 831| s = Replace(s,Chr(9),"",1,-1) 832| If s <> "" Then 833| res(j) = s 834| j = j + 1 835| End If 836| Next 837| 838| ReDim Preserve res(j) 839| ReadListFromFile = res 840| 841| End Function 842| 843| 844| Public Function WriteListToFile(ByRef FileName As String, ByRef pnames() As String) 845| Dim s As String 846| s = Join(pnames,Chr(10)+Chr(13)) 847| SaveTextToFile(FileName,s) 848| End Function 849| 850| 851| Public Function IsValidStrArray(s() As String) As Boolean 852| On Error GoTo ERR_ 853| UBound(s) 'test for empty array (exception) 854| IsValidStrArray = True 855| Exit Function 856| ERR_: 857| IsValidStrArray = False 858| End Function 859| 860| 861| Private Function SaveTextToFile(ByRef fname As String, ByRef txt As String) 862| Dim FN As Integer 863| FN = FreeFile 864| Open fname For Output As #FN 865| Print #FN, txt 866| Close #FN 867| End Function 868| 869| 870| Private Function GetTextFromFile(fname As String) As String 871| Dim FN As Integer 872| FN = FreeFile 873| Dim le As Long 874| On Error GoTo Bad 875| le = FileLen(fname) 876| Open fname For Input As #FN 877| GetTextFromFile = Input(le,FN) 878| Close #FN 879| Exit Function 880| Bad: 881| GetTextFromFile="" 882| End Function 883| 884| 885| Public Function createURLShortCut(ByVal URL As String, Optional ByVal FileName As String = "hn273ShortCut.url") As String 886| 887| createURLShortCut = "" 888| 889| Dim FN As Integer 890| FN = FreeFile 891| FileName = Environ("TEMP") & "\" & FileName 892| Open FileName For Output As #FN 893| Print #FN, "[InternetShortcut]" 894| Print #FN, "URL=" & URL 895| 'Print #FN, "Modified=9038803A3E9DC20120" 896| Close #FN 897| 898| createURLShortCut = filename 899| 900| End Function 901| 902| 903| 904| 905| Public Sub ScreensaverSwitch(Activate As Boolean) 906| 907| SystemParametersInfo CLng(17), CLng(Activate), 0&, CLng(0&) 908| 909| End Sub 910| 911| 912| 913| '''''''''''''''''''''''' StringValidation and AutoCorrection '''''''''''''''''''''''''''''''''' 914| Public Function hn_ValidateStr(ByRef s As String, Optional ByVal CheckAgainst As StringType = alphanumericPathStr, Optional ByVal DoStrCorrection As StringCorrectionType = None) As StrValidationObj 915| 916| On Error GoTo ErrHandler 917| 918| Dim ControlCheck As StrValidationObj 919| Dim i As Integer 920| 921| hn_ValidateStr.Typ = CheckAgainst 922| 923| 924| Select Case DoStrCorrection 925| 926| Case OnlyGermanUmlauts 927| 928| If CheckAgainst = germanUmlaut Then CheckAgainst = germanUmlautsConverted 929| 930| If StrHasGermanUmlauts(s) Then s = ConvertGermanUmlauts(s) 931| 932| For i = 1 To Len(s) 933| If Not IsValidChar(Asc(Mid$(s, i, 1)),CheckAgainst) Then GoTo Escape 934| If ((CheckAgainst=alphanumericPathStr) Or (CheckAgainst=alphanumericPathStrNoBlancs)) And Mid$(s, i, 1)=":" And i<>2 Then GoTo Escape 935| Next i 936| 937| ControlCheck = hn_ValidateStr(s,CheckAgainst,None) 938| hn_ValidateStr.isValid = ControlCheck.isValid 939| hn_ValidateStr.hasGermanUmlauts = ControlCheck.hasGermanUmlauts 940| hn_ValidateStr.Typ = ControlCheck.Typ 941| 942| 943| Case FullCleaning 944| 945| If CheckAgainst = germanUmlaut Then CheckAgainst = germanUmlautsConverted 946| 947| s = DoFullStrCleaning(s,CheckAgainst) 948| 949| ControlCheck = hn_ValidateStr(s,CheckAgainst,None) 950| hn_ValidateStr.isValid = ControlCheck.isValid 951| hn_ValidateStr.hasGermanUmlauts = ControlCheck.hasGermanUmlauts 952| hn_ValidateStr.Typ = ControlCheck.Typ 953| 954| 955| Case None 956| 957| hn_ValidateStr.hasGermanUmlauts = StrHasGermanUmlauts(s) 958| If hn_ValidateStr.hasGermanUmlauts And CheckAgainst <> germanUmlaut Then GoTo Escape 959| 960| For i = 1 To Len(s) 961| If Not IsValidChar(Asc(Mid$(s, i, 1)),CheckAgainst) Then GoTo Escape 962| If CheckAgainst=alphanumericPathStr And Mid$(s, i, 1)=":" And i<>2 Then GoTo Escape 963| Next i 964| 965| hn_ValidateStr.isValid = True 966| 967| End Select 968| 969| 970| Escape: 971| Exit Function 972| 973| ErrHandler: 974| ErrMsg(Err) 975| Resume Escape 976| 977| End Function 978| 'AutoCorrection for String''''''' 979| Private Function DoFullStrCleaning(ByVal s As String, ByVal CheckAgainst As StringType) As String 980| 981| 982| s = Trim$(s) 983| 's = ClearAsciiStr(s," ") 984| If StrHasGermanUmlauts(s) Then s = ConvertGermanUmlauts(s) 985| 986| Dim i As Integer, Char As String 987| Dim PLATZHALTER As String 988| ' Da die Umlaute schon konvertiert wurden kann man hier gefahrlos einen Umlaut als Platzhalter nutzen 989| 990| For i = 1 To Len(s) 991| Char = Mid$(s, i, 1) 992| If Char<>PLATZHALTER And Not IsValidChar(Asc(Char),CheckAgainst) Then s = DoReplaceStr(s,Char,PLATZHALTER) 993| If CheckAgainst=alphanumericPathStr And Char=":" And i<>2 Then Exit For 994| Next i 995| 996| s = DoReplaceStr(s," "," ") 997| s = DoReplaceStr(s," ","_") 998| s = DoReplaceStr(s,PLATZHALTER,"") 999| 1000| DoFullStrCleaning = s 1001| 1002| 1003| End Function 1004| 'Check Chars '''''' 1005| Private Function IsValidChar(ByVal i As Integer, ByVal CheckAgainst As StringType) As Boolean 1006| Select Case CheckAgainst 1007| Case numeric 1008| If IsCharNumeric(i) Then IsValidChar = True 1009| Case alpha 1010| If IsCharAlpha(i) Then IsValidChar = True 1011| Case germanUmlaut 1012| If IsCharGermanUmlaut(i) Then IsValidChar = True 1013| Case germanUmlautsConverted 1014| If IsCharConvertedGermanUmlaut(i) Then IsValidChar = True 1015| Case alphanumeric 1016| If IsCharAlpha(i) Or IsCharNumeric(i) Then IsValidChar = True 1017| Case alphanumericFileName 1018| If IsCharFileName(i) Then IsValidChar = True 1019| Case alphanumericPathStr 1020| If IsCharPathStr(i) Then IsValidChar = True 1021| Case Else 1022| IsValidChar = False 1023| End Select 1024| End Function 1025| Private Function IsCharPathStr(ByVal i As Integer) As Boolean 1026| If IsCharFileName(i) = True Then 1027| IsCharPathStr = True 1028| Else 1029| Select Case i 1030| Case 58 ' DOPPELPUNKT (:) 1031| IsCharPathStr = True 1032| Case 92 ' BACKSLASH (\) 1033| IsCharPathStr = True 1034| End Select 1035| End If 1036| End Function 1037| Private Function IsCharPathStrNoBlancs(ByVal i As Integer) As Boolean 1038| If IsCharFileNameNoBlancs(i) = True Then 1039| IsCharPathStrNoBlancs = True 1040| Else 1041| Select Case i 1042| Case 58 ' DOPPELPUNKT (:) 1043| IsCharPathStrNoBlancs = True 1044| Case 92 ' BACKSLASH (\) 1045| IsCharPathStrNoBlancs = True 1046| End Select 1047| End If 1048| End Function 1049| Private Function IsCharFileName(ByVal i As Integer) As Boolean 1050| If IsCharAlpha(i) Or IsCharNumeric(i) Then 1051| IsCharFileName = True 1052| Else 1053| Select Case i 1054| Case 32 ' LEERZEICHEN ( ) 1055| IsCharFileName = True 1056| Case 45 ' MINUSZEICHEN (-) 1057| IsCharFileName = True 1058| Case 40 ' Klammer-Auf (() 1059| IsCharFileName = True 1060| Case 41 ' Klammer-Zu ()) 1061| IsCharFileName = True 1062| Case 45 ' MINUSZEICHEN (-) 1063| IsCharFileName = True 1064| Case 46 ' PUNKT (.) 1065| IsCharFileName = True 1066| Case 95 ' UNTERSTRICH (_) 1067| IsCharFileName = True 1068| End Select 1069| End If 1070| End Function 1071| Private Function IsCharFileNameNoBlancs(ByVal i As Integer) As Boolean 1072| If IsCharAlpha(i) Or IsCharNumeric(i) Then 1073| IsCharFileNameNoBlancs = True 1074| Else 1075| Select Case i 1076| Case 45 ' MINUSZEICHEN (-) 1077| IsCharFileNameNoBlancs = True 1078| Case 40 ' Klammer-Auf (() 1079| IsCharFileNameNoBlancs = True 1080| Case 41 ' Klammer-Zu ()) 1081| IsCharFileNameNoBlancs = True 1082| Case 45 ' MINUSZEICHEN (-) 1083| IsCharFileNameNoBlancs = True 1084| Case 46 ' PUNKT (.) 1085| IsCharFileNameNoBlancs = True 1086| Case 95 ' UNTERSTRICH (_) 1087| IsCharFileNameNoBlancs = True 1088| End Select 1089| End If 1090| End Function 1091| Private Function IsCharAlpha(ByVal i As Integer) As Boolean 1092| If (i>64 And i<91) Or (i>96 And i<123) Then 1093| IsCharAlpha = True 1094| End If 1095| End Function 1096| Private Function IsCharNumeric(ByVal i As Integer) As Boolean 1097| If (i>47 And i<58) Then 1098| IsCharNumeric = True 1099| End If 1100| End Function 1101| Private Function IsCharGermanUmlaut(ByVal i As Integer) As Boolean 1102| If i=196 Or i=214 Or i=220 Or i=223 Or i=228 Or i=246 Or i=252 Then 1103| IsCharGermanUmlaut = True 1104| End If 1105| End Function 1106| Private Function IsCharConvertedGermanUmlaut(ByVal i As Integer) As Boolean 1107| If i=65 Or i=79 Or i=85 Or i=97 Or i=101 Or i=111 Or i=117 Or i=115 Then 1108| IsCharConvertedGermanUmlaut = True 1109| End If 1110| End Function 1111| 1112| 1113| Public Function DoReplaceStr(ByVal InString As String, ByVal findThis As String, ByVal replaceWith As String) As String 1114| 1115| On Error GoTo ErrHandler 1116| 1117| '## DEBUGMESSAGE ## 1118| ' DoDbgMsg(high,"",FunctionEntry,"findThis=(" & findThis & ") replaceWith=(" & replaceWith & ")" & " || InString=(" & InString & ")") 1119| '## DEBUGMESSAGE ## 1120| 1121| If InStr(replaceWith, findThis) > 0 Then 1122| MsgBox "We cannot process search/replace because:" & vbNewLine & "the String to find is also in the string to replace with!" & vbNewLine & vbNewLine & "FindThis: " & findThis & vbNewLine & "ReplaceWith: " & replaceWith, vbExclamation, SCRIPTNAME & " (DoReplaceStr)" 1123| DoReplaceStr = InString 1124| GoTo Escape 1125| End If 1126| 1127| Dim pos As Long, le As Long 1128| le = Len(findThis) 1129| Do 1130| pos = InStr(InString, findThis) 1131| If pos = 0 Then Exit Do 1132| InString = Left$(InString, pos - 1) & replaceWith & Mid$(InString, pos + le, Len(InString)) 1133| Loop 1134| DoReplaceStr = InString 1135| 1136| 1137| Escape: 1138| Exit Function 1139| 1140| ErrHandler: 1141| ErrMsg(Err) 1142| Resume Escape 1143| 1144| End Function 1145| 1146| 1147| Public Function StrHasGermanUmlauts(ByVal s As String) As Boolean 1148| 1149| On Error GoTo ErrHandler 1150| 1151| Dim i As Integer 1152| For i = 1 To Len(s) 1153| If IsValidChar(Asc(Mid$(s, i, 1)),germanUmlaut) Then StrHasGermanUmlauts = True: Exit Function 1154| Next i 1155| 1156| Escape: 1157| Exit Function 1158| 1159| ErrHandler: 1160| ErrMsg(Err) 1161| Resume Escape 1162| 1163| End Function 1164| 1165| 1166| Public Function ConvertGermanUmlauts(ByVal s As String) As String 1167| 1168| On Error GoTo ErrHandler 1169| 1170| 1171| 1172| 1173| 1174| 1175| 1176| 1177| ConvertGermanUmlauts = s 1178| 1179| Escape: 1180| Exit Function 1181| 1182| ErrHandler: 1183| ErrMsg(Err) 1184| Resume Escape 1185| 1186| End Function 1187| 1188| 1189| Public Function ClearAsciiStr(ByVal StrToClear As String, Optional ByVal ReplaceWithStr As String = " ") As String 1190| 1191| On Error GoTo ErrHandler 1192| 1193| Dim t As Long, i As Integer 1194| If InStr(StrToClear, Chr$(127)) Then StrToClear = DoReplaceStr(StrToClear, Chr$(127), ReplaceWithStr) 1195| For t = 1 To Len(StrToClear) 1196| i = Asc(Mid$(StrToClear, t, 1)) 1197| If i < 32 Then Mid$(StrToClear, t, 1) = ReplaceWithStr 1198| Next t 1199| ClearAsciiStr = StrToClear 1200| 1201| 1202| Escape: 1203| Exit Function 1204| 1205| ErrHandler: 1206| ErrMsg(Err) 1207| Resume Escape 1208| 1209| End Function 1210| 1211| 1212| '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 1213| 'Variablen Funktionen 1214| Public Function hn_TypeOf(ByRef TheVar As Variant) As VarIsOf 1215| hn_TypeOf = VarType(TheVar) 1216| End Function 1217| 1218| 1219| 1220| '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 1221| 1222| Public Function hn_friendlyBitStr(ByVal Amount As Double) As String 1223| 1224| On Error GoTo ErrHandler 1225| 1226| Dim i As Integer 1227| Dim ext() As String 1228| Dim file_size As Double, new_file_size As Double 1229| 1230| ReDim ext(0 To 4) 1231| ext(0) = " B" 1232| ext(1) = " KB" 1233| ext(2) = " MB" 1234| ext(3) = " GB" 1235| ext(4) = " TB" 1236| i = 0 1237| file_size = Amount 1238| hn_friendlyBitStr = CStr(file_size) & ext(i) 1239| 1240| While (file_size >= pow(1024,i)) 1241| new_file_size = Round(file_size / pow(1024,i),2) 1242| hn_friendlyBitStr = CStr(new_file_size) & ext(i) 1243| i = i +1 1244| Wend 1245| 1246| hn_friendlyBitStr = DoReplaceStr(hn_friendlyBitStr,".",",") 1247| 1248| 1249| Escape: 1250| Exit Function 1251| 1252| ErrHandler: 1253| ErrMsg(Err) 1254| Resume Escape 1255| 1256| End Function 1257| 1258| 1259| 1260| 1261| Public Function hn_friendlyFilesizeStr(ByVal FullpathFilename As String) As String 1262| 1263| 1264| On Error GoTo ErrHandler 1265| 1266| If hn_FileExists(FullpathFilename) Then 1267| Dim i As Integer 1268| Dim ext() As String 1269| Dim file_size As Double, new_file_size As Double 1270| 1271| ReDim ext(0 To 4) 1272| ext(0) = " B" 1273| ext(1) = " KB" 1274| ext(2) = " MB" 1275| ext(3) = " GB" 1276| ext(4) = " TB" 1277| i = 0 1278| file_size = FileLen(FullpathFilename) 1279| hn_friendlyFilesizeStr = CStr(file_size) & ext(i) 1280| 1281| While (file_size >= pow(1024,i)) 1282| new_file_size = Round(file_size / pow(1024,i),2) 1283| hn_friendlyFilesizeStr = CStr(new_file_size) & ext(i) 1284| i = i +1 1285| Wend 1286| 1287| hn_friendlyFilesizeStr = DoReplaceStr(hn_friendlyFilesizeStr,".",",") 1288| 1289| Else 1290| hn_friendlyFilesizeStr = "0" 1291| End If 1292| 1293| 1294| Escape: 1295| Exit Function 1296| 1297| ErrHandler: 1298| ErrMsg(Err) 1299| Resume Escape 1300| 1301| End Function 1302| 1303| Public Function hn_friendlyTimerStr(ByVal TheTime As Double, Optional ByVal LongStrFormat As Boolean = True) As String 1304| 1305| On Error GoTo ErrHandler 1306| 1307| 1308| If TheTime < 0 Then TheTime = TheTime + 86400 1309| 1310| 1311| If TheTime <= 180 Then 1312| 1313| If Round(TheTime,3) > 0.0009 Then 1314| hn_friendlyTimerStr = CStr(Round(TheTime,3)) 1315| Else 1316| hn_friendlyTimerStr = CStr(TheTime) 1317| End If 1318| If LongStrFormat Then hn_friendlyTimerStr = hn_friendlyTimerStr & " seconds" 1319| 1320| ElseIf TheTime <= 86400 Then 1321| 1322| Dim i As Integer, k As Integer 1323| Dim ext() As String 1324| Dim new_size As Double, new_size2 As Double 1325| 1326| ReDim ext(0 To 2) 1327| ext(0) = " seconds" 1328| ext(1) = " minutes" 1329| ext(2) = " hours" 1330| i = 0 1331| new_size = Round(TheTime) 1332| 1333| While (TheTime >= pow(60,i)) 1334| new_size = Round(TheTime / pow(60,i),2) 1335| i = i +1 1336| Wend 1337| 1338| hn_friendlyTimerStr = CStr(new_size) & ext(i-1) 1339| 1340| Else 1341| hn_friendlyTimerStr = CStr(TheTime) 1342| End If 1343| 1344| 1345| Escape: 1346| Exit Function 1347| 1348| ErrHandler: 1349| ErrMsg(Err) 1350| Resume Escape 1351| 1352| End Function 1353| 1354| Public Function pow(ByVal basis As Double, ByVal exponent As Integer) As Double 1355| 1356| On Error GoTo ErrHandler 1357| 1358| Dim x As Double, k As Integer 1359| x = basis 1360| k = 1 1361| While exponent > k 1362| basis = basis * x 1363| k = k +1 1364| Wend 1365| pow = basis 1366| 1367| 1368| Escape: 1369| Exit Function 1370| 1371| ErrHandler: 1372| ErrMsg(Err) 1373| Resume Escape 1374| 1375| End Function 1376| 1377| 1378| Public Function RemoveAllBookmarks(Optional ByRef DB As Database, Optional ByRef Selection As Images) As Boolean 1379| 1380| On Error GoTo ErrHandler 1381| 1382| If DB Is Nothing Then 1383| Set DB = Application.ActiveDatabase 1384| If DB Is Nothing Then Exit Function 1385| End If 1386| If Selection Is Nothing Then Set Selection = DB.Bookmarks 1387| DB.RemoveBookmarks(Selection) 1388| RemoveAllBookmarks = True 1389| 1390| Escape: 1391| Exit Function 1392| 1393| ErrHandler: 1394| ErrMsg(Err) 1395| Resume Escape 1396| 1397| End Function 1398| 1399| Public Function BookmarksOn(ByRef Selection As Images, Optional ByVal DB As Database) As Boolean 1400| 1401| On Error GoTo ErrHandler 1402| 1403| If DB Is Nothing Then Set DB = Application.ActiveDatabase 1404| If Selection Is Nothing Then GoTo Escape 1405| 1406| DB.AddBookmarks(Selection) 1407| BookmarksOn = True 1408| 1409| Escape: 1410| Exit Function 1411| 1412| ErrHandler: 1413| ErrMsg(Err) 1414| Resume Escape 1415| 1416| End Function 1417| 1418| Public Function BookmarksOff(ByRef Selection As Images, Optional ByVal DB As Database) As Boolean 1419| 1420| On Error GoTo ErrHandler 1421| 1422| If DB Is Nothing Then Set DB = Application.ActiveDatabase 1423| If Selection Is Nothing Then GoTo Escape 1424| 1425| DB.RemoveBookmarks(Selection) 1426| BookmarksOff = True 1427| 1428| Escape: 1429| Exit Function 1430| 1431| ErrHandler: 1432| ErrMsg(Err) 1433| Resume Escape 1434| 1435| End Function 1436| 1437| 1438| Public Function hn_SetListBoxByStrVal(ByRef StrArray() As String, ByRef SearchedValue As String, Optional ByRef CorrectureValue As Variant = "auto") As Integer 1439| 1440| 'The Listboxes starts by an Index of 0, If the Array starts by an Index of 1, the ResultCode must be corrected. 1441| 'Per default we do that automaticly. If the user gives another value than "auto" we take that value as an integer. 1442| 1443| On Error GoTo ErrHandler 1444| Dim k As Integer 1445| If CorrectureValue = "auto" Then 1446| If LBound(StrArray) = 0 Then 1447| CorrectureValue = 0 1448| ElseIf LBound(StrArray) = 1 Then 1449| CorrectureValue = -1 1450| Else 1451| CorrectureValue = CInt(CorrectureValue) * (-1) 1452| End If 1453| End If 1454| 1455| If UBound(StrArray) >= 0 And SearchedValue <> "" Then 1456| For k = LBound(StrArray) To UBound(StrArray) 1457| If StrArray(k) = SearchedValue Then 1458| hn_SetListBoxByStrVal = k + (CInt(CorrectureValue)) 1459| Exit Function 1460| End If 1461| Next 1462| Else 1463| hn_SetListBoxByStrVal = 0 1464| End If 1465| 1466| 1467| Escape: 1468| Exit Function 1469| 1470| ErrHandler: 1471| ErrMsg(Err) 1472| GoTo Escape 1473| 1474| End Function 1475| 1476| 1477| 1478| Public Function hn_BuildOfflineCacheFilenameStr(ByRef DB As Database, ByRef PicT As Image) As FileStrObj 1479| 'Needs the global Constants "OFFLINECACHE_MAINFOLDER" set to MainPath of IMatch's OfflineCacheFolder 1480| 'This Constant is to define in "hnPublicDeclarations.lib" => Sub: InitializeGlobalVars 1481| 1482| On Error GoTo ErrHandler 1483| 1484| Dim DBoid As String 1485| Dim OCfolder As String 1486| Dim DoDebug As Boolean 1487| 1488| DoDebug = False 1489| DBoid = DoReplaceStr(DB.OID, "-", "") 1490| DBoid = LCase(Left(DBoid,15)) 1491| OCfolder = LCase(Dir(OFFLINECACHE_MAINFOLDER & "*.*",vbDirectory)) 1492| 1493| If DoDebug Then Debug.Print "DBoid: " & DBoid & " | Len(DBoid): " & Len(DBoid) 1494| 1495| 'Scan OfflineCacheMainFolder for subfoldernames 1496| While OCfolder <> "" 1497| If DoDebug Then Debug.Print "OCfolder: " & OCfolder 1498| If DoDebug Then Debug.Print "Left(OCfolder, Len(DBoid)): " & Left(OCfolder, Len(DBoid)) 1499| If Left(OCfolder, Len(DBoid)) = DBoid Then 1500| hn_BuildOfflineCacheFilenameStr = hn_FileStrObject(hn_BuildFolderStr(OFFLINECACHE_MAINFOLDER, OCfolder) & Left(CStr(PicT.OID), 2) & "\" & PicT.OID & ".jpg") 1501| If DoDebug Then Debug.Print hn_BuildOfflineCacheFilenameStr.PathFull 1502| Exit While 1503| End If 1504| OCfolder = LCase(Dir()) 1505| Wend 1506| 1507| Escape: 1508| Exit Function 1509| 1510| ErrHandler: 1511| ErrMsg(Err) 1512| GoTo Escape 1513| 1514| End Function 1515| 1516| 1517| Public Function hn_BuildOfflineCacheFolderStr(ByRef DB As Database, ByVal OLC_Rootfolder As String) As String 1518| 1519| On Error GoTo ErrHandler 1520| 1521| Dim DBoid As String 1522| Dim OLCfolder As String 1523| Dim DoDebug As Boolean 1524| DoDebug = False 1525| 1526| DBoid = DoReplaceStr(DB.OID, "-", "") 1527| DBoid = LCase(Left(DBoid,15)) 1528| OLCfolder = LCase(Dir(OLC_Rootfolder & "*.*",vbDirectory)) 1529| 1530| If DoDebug Then Debug.Print "DBoid: " & DBoid & " | Len(DBoid): " & Len(DBoid) 1531| 1532| 'Scan OfflineCacheMainFolder for subfoldernames 1533| While OLCfolder <> "" 1534| If DoDebug Then 1535| Debug.Print "OLCfolder: " & OLCfolder 1536| Debug.Print "Left(OLCfolder, Len(DBoid)): " & Left(OLCfolder, Len(DBoid)) 1537| End If 1538| If Left(OLCfolder, Len(DBoid)) = DBoid Then 1539| hn_BuildOfflineCacheFolderStr = hn_BuildFolderStr(OLC_Rootfolder, OLCfolder) 1540| If DoDebug Then Debug.Print hn_BuildOfflineCacheFolderStr 1541| Exit While 1542| End If 1543| OLCfolder = LCase(Dir()) 1544| Wend 1545| 1546| Escape: 1547| Exit Function 1548| 1549| ErrHandler: 1550| ErrMsg(Err) 1551| Resume Escape 1552| 1553| End Function 1554| 1555| 1556| Public Function hn_AddImageToDB(ByRef ImageFileName As String, Optional ByRef DB As Database, Optional ByRef RootFolder As String = "") As IMFileOperationResults 1557| 1558| On Error GoTo ErrHandler 1559| Dim DoDebug As Boolean 1560| DoDebug = False 1561| 1562| 1563| If DB Is Nothing Then Set DB = Application.ActiveDatabase 1564| If DoDebug Then Debug.Print"Working with database: " & DB.FileName 1565| 1566| Dim img As Image 1567| Set img = DB.GetImages(ImageFileName) 1568| 1569| If img Is Nothing Then 1570| 1571| If CDbl(Left(Application.Version, 3)) < 3.3 Then 1572| 1573| hn_AddImageToDB = DB.AddImage(ImageFileName) 1574| If DoDebug Then Debug.Print "This is a previous version then 3.3.x, we only add the Image to DB:" & vbNewLine & " - " & ImageFileName 1575| 1576| Else 1577| 1578| Dim Folder As String 1579| Folder = hn_FileStrObject(ImageFileName).PathWithDrive 1580| Dim Fld As IMFolder 1581| 1582| If RootFolder <> "" Then 1583| 1584| Dim SubFolders() As String, k As Integer 1585| SubFolders = Split(Right(hn_BuildFolderStr(Folder,,False), Len(Folder) - Len(RootFolder)), "\") 1586| 1587| If hn_FileExists(RootFolder,vbDirectory) And (DB.GetFolder(RootFolder) Is Nothing) Then 1588| DB.AddFolder(RootFolder) 1589| If DoDebug Then Debug.Print "This is a higher version then 3.3.0, and we first want to add a RootFolder to DB:" & vbNewLine & " - adding RootFolder: " & RootFolder 1590| End If 1591| Folder = RootFolder 1592| For k = LBound(SubFolders) To UBound(SubFolders) -1 1593| Folder = hn_BuildFolderStr(Folder, SubFolders(k),False) 1594| If hn_FileExists(Folder,vbDirectory) And (DB.GetFolder(Folder) Is Nothing) Then DB.AddFolder(Folder) 1595| If DoDebug Then Debug.Print " - adding Subfolder: " & Folder 1596| Next k 1597| 1598| Else 1599| 1600| If hn_FileExists(Folder,vbDirectory) And (DB.GetFolder(Folder) Is Nothing) Then DB.AddFolder(Folder) 1601| If DoDebug Then Debug.Print "This is a higher version then 3.3.0, we first add the Folder to DB:" & vbNewLine & " - " & Folder 1602| 1603| End If 1604| 1605| hn_AddImageToDB = DB.AddImage(ImageFileName) 1606| If DoDebug Then Debug.Print " - Now we add the Image to DB:" & vbNewLine & " - " & ImageFileName 1607| 1608| End If 1609| 1610| Else 1611| 1612| Application.UpdateDatabase(ImageFileName,True) 1613| If DoDebug Then Debug.Print " - The Image is already in database, so we only have to update DB." & vbNewLine & " - Imagename: " & ImageFileName 1614| 1615| End If 1616| 1617| 1618| Escape: 1619| If DoDebug Then Debug.Print " - We return this result to calling script: " & hn_AddImageToDB 1620| Exit Function 1621| 1622| ErrHandler: 1623| ErrMsg(Err) 1624| Resume Escape 1625| 1626| End Function 1627| 1628| 1629| 1630| Public Function hn_AddFolderToDB(ByRef FullPathFolderName As String, Optional ByRef DB As Database, Optional ByRef RootFolder As String = "") As IMFolder 1631| 1632| On Error GoTo ErrHandler 1633| Dim DoDebug As Boolean 1634| DoDebug = True 1635| 1636| 1637| If DB Is Nothing Then Set DB = Application.ActiveDatabase 1638| If DoDebug Then Debug.Print "### Function hn_AddFolderToDB ###" & vbNewLine & " - working with database: " & DB.FileName 1639| 1640| 1641| Dim Fld As IMFolder 1642| Dim Folder As String 1643| Folder = FullPathFolderName 1644| 1645| 1646| If hn_FileExists(FullPathFolderName, vbDirectory) Then 1647| 1648| If RootFolder <> "" Then 1649| 1650| If DoDebug Then Debug.Print " ... we first add a RootFolder to DB:" & vbNewLine & " - adding RootFolder: " & RootFolder 1651| 1652| Dim SubFolders() As String, k As Integer 1653| SubFolders = Split(Right(hn_BuildFolderStr(Folder,,False), Len(Folder) - Len(RootFolder)), "\") 1654| 1655| If hn_FileExists(RootFolder,vbDirectory) And (DB.GetFolder(RootFolder) Is Nothing) Then 1656| DB.AddFolder(RootFolder) 1657| End If 1658| Folder = RootFolder 1659| For k = LBound(SubFolders) To UBound(SubFolders) -1 1660| Folder = hn_BuildFolderStr(Folder, SubFolders(k),False) 1661| If hn_FileExists(Folder,vbDirectory) And (DB.GetFolder(Folder) Is Nothing) Then DB.AddFolder(Folder) 1662| If DoDebug Then Debug.Print " - adding Subfolder: " & Folder 1663| Next k 1664| Else 1665| 1666| If DoDebug Then Debug.Print " - adding Folder: " & Folder 1667| If hn_FileExists(Folder, vbDirectory) And (DB.GetFolder(Folder) Is Nothing) Then DB.AddFolder(Folder) 1668| 1669| End If 1670| 1671| Else 1672| If DoDebug Then Debug.Print " ... the folder you wants to add to DB doesn't exist or isn't reachable yet: " & FullPathFolderName 1673| End If 1674| 1675| 1676| Set hn_AddFolderToDB = DB.GetFolder(FullPathFolderName) 1677| 1678| Escape: 1679| If DoDebug Then 1680| If Not hn_AddFolderToDB Is Nothing Then 1681| Debug.Print " ... our result is an IMFolder with this path: " & hn_AddFolderToDB.Path 1682| Else 1683| Debug.Print " ... our result is: NOTHING!" 1684| End If 1685| End If 1686| Exit Function 1687| 1688| ErrHandler: 1689| ErrMsg(Err) 1690| Resume Escape 1691| 1692| End Function 1693| 1694| 1695| Public Function hn_AddCatToDB(ByRef StrCatName As String, ByRef DB As Database, Optional ByRef ParentCat As Category = Nothing) As Category 1696| 1697| On Error GoTo ErrHandler 1698| 1699| Dim FullName As String 1700| 1701| If Not DB Is Nothing Then 1702| 1703| If Not ParentCat Is Nothing Then 1704| FullName = ParentCat.FullName & "." & StrCatName 1705| Else 1706| FullName = StrCatName 1707| End If 1708| 1709| If DB.Categories(CStr(FullName)) Is Nothing Then 1710| Set hn_AddCatToDB = DB.Categories.Add(StrCatName, ParentCat) 1711| Else 1712| Set hn_AddCatToDB = DB.Categories(CStr(FullName)) 1713| End If 1714| 1715| End If 1716| 1717| Escape: 1718| Exit Function 1719| 1720| ErrHandler: 1721| ErrMsg(Err) 1722| Resume Escape 1723| 1724| End Function 1725| 1726| 1727| Public Function hn_BucketSafe(ByRef Bucket As ImageBucket, ByVal FileName As String) As Boolean 1728| 1729| On Error GoTo ErrHandler 1730| 'On Error Resume Next 1731| 1732| Dim A() As String 1733| Dim k As Integer 1734| Dim PicT As Image, P2 As Image 1735| 1736| 'Building Array with OID's 1737| If Bucket.Count > 1 Then 1738| ReDim A(1 To CInt(Bucket.Count)) As String 1739| For Each PicT In Bucket 1740| k = k +1 1741| A(k) = CStr(PicT.OID) 1742| Next PicT 1743| End If 1744| 1745| 'Saving Array with OID's to Textfile 1746| If IsValidStrArray(A()) Then 1747| SortStringArray(A()) 1748| WriteListToFile(FileName, A()) 1749| End If 1750| 1751| 'Check if we can read the Listfile 1752| hn_BucketSafe = IsValidStrArray(ReadListFromFile(FileName)) 1753| 1754| 1755| Escape: 1756| Exit Function 1757| 1758| ErrHandler: 1759| ErrMsg(Err) 1760| Resume Escape 1761| 1762| End Function 1763| 1764| Public Function hn_BucketLoad(ByRef Bucket As ImageBucket, ByVal FileName As String, ByRef DB As Database) As Boolean 1765| 1766| On Error GoTo ErrHandler 1767| 1768| Dim A() As String 1769| Dim k As Integer 1770| Dim PicT As Image 1771| 1772| 'Reading List into Array 1773| A() = ReadListFromFile(FileName) 1774| 1775| Bucket.Clear 1776| 'Building the Bucket from OID's in Array 1777| If IsValidStrArray(A()) Then 1778| For k = LBound(A) To UBound(A)-1 1779| Debug.Print "k: " & k & " = " & "A(" & A(k) & ")" 1780| For Each PicT In DB.GetImages 1781| If CLng(PicT.OID) = CLng(A(k)) Then Exit For 1782| Next 1783| If Not PicT Is Nothing Then 1784| Debug.Print "PicT.Name: " & PicT.Name 1785| Bucket.CombineImage(PicT) 1786| End If 1787| Next k 1788| End If 1789| 1790| hn_BucketLoad = IsValidStrArray(ReadListFromFile(FileName)) 1791| 1792| 1793| Escape: 1794| Exit Function 1795| 1796| ErrHandler: 1797| ErrMsg(Err) 1798| Resume Escape 1799| 1800| End Function 1801| 1802| 1803| Public Function GetWinHandleByName(ByRef WinName As String) As Long 1804| 1805| On Error GoTo ErrHandler 1806| 1807| GetWinHandleByName = FindWindow(CStr(Null), WinName) 1808| 1809| Escape: 1810| Exit Function 1811| 1812| ErrHandler: 1813| ErrMsg(Err) 1814| Resume Escape 1815| 1816| End Function 1817| 1818| Public Function WinTransparentSet(ByRef WinName As String) As Boolean 1819| 1820| On Error GoTo ErrHandler 1821| 1822| Dim MySysInfo As clsSysInfo 1823| Set MySysInfo = New clsSysInfo 1824| 1825| If MySysInfo.WinNT And MySysInfo.NTVersion > 4 Then 1826| 1827| MsgBox CStr(MySysInfo.NTVersion) 1828| 1829| Dim CurStyle As Long 1830| Dim WinHandle As Long 1831| 1832| WinHandle = GetWinHandleByName(WinName) 1833| CurStyle = GetWindowLong(WinHandle, GWL_EXSTYLE) 1834| 1835| Call SetWindowLong(WinHandle, GWL_EXSTYLE, CurStyle Or WS_EX_TRANSPARENT) 1836| 1837| WinTransparentSet = True 1838| 1839| End If 1840| 1841| Escape: 1842| FreeObject(MySysInfo) 1843| Exit Function 1844| 1845| ErrHandler: 1846| ErrMsg(Err) 1847| Resume Escape 1848| 1849| End Function 1850| 1851| Public Function WinTransparentUnset(ByRef WinName As String) As Boolean 1852| 1853| On Error GoTo ErrHandler 1854| 1855| Dim MySysInfo As clsSysInfo 1856| Set MySysInfo = New clsSysInfo 1857| 1858| If MySysInfo.WinNT And MySysInfo.NTVersion > 4 Then 1859| 1860| Dim CurStyle As Long 1861| Dim WinHandle As Long 1862| 1863| WinHandle = GetWinHandleByName(WinName) 1864| CurStyle = GetWindowLong(WinHandle, GWL_EXSTYLE) 1865| 1866| Call SetWindowLong(WinHandle, GWL_EXSTYLE, CurStyle And Not WS_EX_TRANSPARENT) 1867| 1868| WinTransparentUnset = True 1869| 1870| End If 1871| 1872| Escape: 1873| FreeObject(MySysInfo) 1874| Exit Function 1875| 1876| ErrHandler: 1877| ErrMsg(Err) 1878| Resume Escape 1879| 1880| End Function 1881| 1882| 1883| Public Function hn_lcmsConversion(ByRef FullpathSourcefile As String, Optional ByVal InputICC As String, Optional ByVal OutputICC As String, Optional ByVal Params As String, Optional ByVal windowtype As ShellWindowStyle = vbMinimizedNoFocus) As String 1884| ' !! This function needs some defined constants in lib\hnPublicDeclarations.lib !! 1885| 1886| On Error GoTo ErrHandler 1887| 1888| Dim DoDebug As Boolean 1889| DoDebug = False 1890| 1891| Dim typ As String, iccin As String, iccout As String, iccparam As String, tempfile As String, commandline As String 1892| 1893| Dim x As FileStrObj 1894| x = hn_FileStrObject(FullpathSourcefile) 1895| 1896| 1897| 'Check filetype 1898| If DoDebug Then Debug.Print "- hn_lcmsConversion: given filename is " & FullpathSourcefile 1899| If (LCase(x.FType) = "tif" Or LCase(x.FType) = "tiff") Then 1900| typ = "tif" 1901| ElseIf (LCase(x.FType) = "jpg" Or LCase(x.FType) = "jpeg") Then 1902| typ = "jpg" 1903| Else 1904| typ = "undefined" 1905| If hn_FileExists(x.PathFull) Then hn_lcmsConversion = x.PathFull 1906| GoTo Escape 1907| End If 1908| If DoDebug Then Debug.Print "- hn_lcmsConversion: Filetype is " & typ 1909| 1910| 'Check if files exists 1911| If Not hn_FileExists(x.PathFull, vbNormal) Then 1912| If DoDebug Then Debug.Print "- hn_lcmsConversion: Sourcefile does not exist " & x.PathFull 1913| GoTo Failure 1914| End If 1915| If Not hn_FileExists(LCMS_TEMPDIR, vbDirectory) Then 1916| If DoDebug Then Debug.Print "- hn_lcmsConversion: Tempdir exists " & LCMS_TEMPDIR 1917| GoTo Failure 1918| End If 1919| If typ = "tif" And Not hn_FileExists(LCMS_TIFF_EXE, vbNormal) Then 1920| If DoDebug Then Debug.Print "- hn_lcmsConversion: File does not exist: icctiff.exe / " & LCMS_TIFF_EXE 1921| GoTo Failure 1922| End If 1923| If typ = "jpg" And Not hn_FileExists(LCMS_JPEG_EXE, vbNormal) Then 1924| If DoDebug Then Debug.Print "- hn_lcmsConversion: File does not exist: iccjpeg.exe / " & LCMS_JPEG_EXE 1925| GoTo Failure 1926| End If 1927| If OutputICC = "" And Not hn_FileExists(LCMS_SRGB_PROFILE, vbNormal) Then 1928| If DoDebug Then Debug.Print "- hn_lcmsConversion: Standard-Ouput-ICC-file does not exist: srgb.icm / " & LCMS_SRGB_PROFILE 1929| GoTo Failure 1930| End If 1931| If OutputICC <> "" And Not hn_FileExists(OutputICC, vbNormal) Then 1932| If DoDebug Then Debug.Print "- hn_lcmsConversion: Special-Ouput-ICC-file does not exist: / " & OutputICC 1933| GoTo Failure 1934| End If 1935| If InputICC <> "" And Not hn_FileExists(InputICC, vbNormal) Then 1936| If DoDebug Then Debug.Print "- hn_lcmsConversion: Special-Input-ICC-file does not exist: / " & InputICC 1937| GoTo Failure 1938| End If 1939| 1940| 1941| 'set Params 1942| If typ = "tif" Then 1943| If Params <> "" Then 1944| iccparam = Params 1945| Else 1946| iccparam = " " & LCMS_TIFF_PARAM 1947| End If 1948| ElseIf typ = "jpg" Then 1949| If Params <> "" Then 1950| iccparam = Params 1951| Else 1952| iccparam = " " & LCMS_JPEG_PARAM 1953| End If 1954| End If 1955| If OutputICC <> "" Then 1956| iccout = " -o" & OutputICC & " " 1957| Else 1958| iccout = " -o" & LCMS_SRGB_PROFILE & " " 1959| End If 1960| If InputICC <> "" Then iccin = " -i" & InputICC & " " 1961| If DoDebug Then 1962| Debug.Print "- hn_lcmsConversion: iccparam is " & iccparam 1963| Debug.Print "- hn_lcmsConversion: iccin is " & iccin 1964| Debug.Print "- hn_lcmsConversion: iccout is " & iccout 1965| End If 1966| 1967| 1968| 'build targetfilename 1969| tempfile = hn_BuildFolderStr(LCMS_TEMPDIR) & "lcmstmp." & x.FType 1970| If DoDebug Then Debug.Print "- hn_lcmsConversion: tempfile is " & tempfile 1971| 1972| 1973| 'build commandline 1974| If typ = "tif" Then commandline = LCMS_TIFF_EXE & iccparam & iccin & iccout & x.PathFull & " " & tempfile 1975| If typ = "jpg" Then commandline = LCMS_JPEG_EXE & " " & LCMS_JPEG_PARAM & iccin & iccout & x.PathFull & " " & tempfile 1976| 1977| 1978| 'do conversion 1979| If DoDebug Then Debug.Print "- hn_lcmsConversion: the shell call is " & Environ("commandspec") & " /C " & commandline 1980| ShellAndWait(Environ("COMSPEC") & " /C " & commandline, 0, windowtype) 1981| 1982| 1983| 'check if it was successful 1984| If hn_FileExists(tempfile) And FileLen(tempfile) > 8 Then 1985| If DoDebug Then Debug.Print "- hn_lcmsConversion: success, the tempfile was created and it's filesize is " & hn_friendlyFilesizeStr(tempfile) 1986| hn_lcmsConversion = tempfile 1987| Else 1988| If DoDebug Then Debug.Print "- hn_lcmsConversion: failure, the tempfile was not correctly created / it's filesize is " & hn_friendlyFilesizeStr(tempfile) 1989| hn_lcmsConversion = x.PathFull 1990| End If 1991| 1992| 1993| Escape: 1994| If DoDebug Then Debug.Print "- hn_lcmsConversion: the function returns " & hn_lcmsConversion 1995| Exit Function 1996| 1997| ErrHandler: 1998| ErrMsg(Err) 1999| Resume Escape 2000| 2001| Failure: 2002| If hn_FileExists(x.PathFull) Then 2003| hn_lcmsConversion = x.PathFull 2004| If MsgBox("There are not all needed files available for an ICC-Conversion." & vbNewLine & "Please refer to the DebugWindow." & vbNewLine & "(Set the Functions DebugVar to True if there is no output)" & vbNewLine & vbNewLine & "Do you want try continue the script execution?", vbYesNo + vbDefaultButton2 + vbExclamation, "hn_lcmsConversion") = vbNo Then Exit All 2005| GoTo Escape 2006| Else 2007| MsgBox("There are not all needed files available for an ICC-Conversion." & vbNewLine & "Please refer to the DebugWindow." & vbNewLine & "(Set the Functions DebugVar to True if there is no output)" & vbNewLine & vbNewLine & "The script will stop now!", vbExclamation, "hn_lcmsConversion") 2008| Exit All 2009| End If 2010| 2011| End Function 2012| 2013| 2014| Public Function hn_DirIntoArray(ByRef FilenameArray() As String, ByVal FullPathFolder As String, Optional ByVal subfolders As Boolean = False) As Boolean 2015| 2016| On Error GoTo Errhandler 2017| 2018| Dim DoDebugPrint As Boolean 2019| DoDebugPrint = False 2020| 2021| Dim p As String 2022| p = hn_BuildFolderStr(FullPathFolder) 2023| 2024| If DoDebugPrint Then Debug.Print "- Proceed: " & p 2025| 2026| 2027| ' First scan the files in the folder 2028| Dim fname As String 2029| 2030| fname = Dir(p & "*.*",vbNormal) 2031| While fname <> "" 2032| ReDim Preserve FilenameArray(LBound(FilenameArray) To UBound(FilenameArray)+1) 2033| FilenameArray(UBound(FilenameArray)) = p & fname 2034| fname = Dir() 2035| Wend 2036| 2037| 2038| If subfolders Then 2039| 2040| Dim dirs As New IMCollection 2041| 2042| fname = Dir(p & "*.*",vbDirectory) 2043| While fname <> "" 2044| If (GetAttr(p & fname) And vbDirectory) = vbDirectory Then 2045| If Left(fname,1) <> "." Then 2046| dirs.Add p & fname 2047| If DoDebugPrint Then Debug.Print "- Found SubDir: " & p & fname 2048| End If 2049| End If 2050| fname = Dir() 2051| Wend 2052| 2053| Dim d As Variant 2054| For Each d In dirs 2055| hn_DirIntoArray(FilenameArray(), d, subfolders) 2056| Next d 2057| 2058| Set dirs = Nothing 2059| End If 2060| 2061| Escape: 2062| Exit Function 2063| 2064| ErrHandler: 2065| ErrMsg(Err) 2066| Resume Escape 2067| 2068| End Function 2069| 2070| 2071| 2072| 2073|