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]
hnFncPSOLE.lib: (702 lines / 386 real codelines / 2 Subs / 18 Functions / 0 Properties)
1| '#Reference {4B0AB3E1-80F1-11CF-86B4-444553540000}#6.0#409#D:\Programme\Adobe\Photoshop 6.0\TypeLibrary.tlb#Adobe Photoshop 6.0 Type Library 2| 3| 'This file needs the Adobe Photoshop 5.5 or 6.0 Type Library 4| 'Check: Edit > References 5| 6| '#uses "hnPublicDeclarations.lib" 7| '#uses "hnPSoleDeclarations.lib" 8| '#uses "hnClsRegKey.cls" 9| 10| 11| Option Explicit 12| 13| 'Global Variables (Descriptors, ControlObjects, etc) 14| Public PS_App As PhotoshopApplication 15| Public PS_Control As IActionControl 16| Public PS_Params As IActionDescriptor 17| Public PS_Desc As IActionDescriptor 18| Public PS_Result As IActionDescriptor 19| Public PS_Action As IAction 20| Public OLE_TimeOut As Long 21| Public ffglobal As PSffGlobal 22| 23| 24| 25| 26| Public Function PS_OLE_Start(Optional ByRef Reg As clsRegKey) As String 27| 28| If Reg Is Nothing Then 29| Set Reg = New clsRegKey 30| Reg.ClassInit("PSOLE_LIB") 31| End If 32| 33| On Error Resume Next 34| AppActivate "Adobe Photoshop" 35| If Err.Number <> 0 Then 36| Err.Clear 37| On Error GoTo Err_ 38| Application.OLEServerBusyTimeout = OLE_TimeOut 39| Reg.SaveKey("FirstStart",True,AsBoolean) 40| Else 41| Reg.SaveKey("FirstStart",False,AsBoolean) 42| End If 43| 44| Set PS_App = CreateObject("Photoshop.Application") 45| Set PS_Params = PS_App.MakeDescriptor 46| Set PS_Desc = PS_App.MakeDescriptor 47| Set PS_Control = PS_App.MakeControlObject 48| 49| 50| Exit_: 51| Exit Function 52| Err_: 53| PS_OLE_Start = "PS_OLE_Start = Error Nr: " & Err.Number & vbNewLine & Err.Description 54| Resume Exit_ 55| 56| End Function 57| 58| 59| Public Function PS_OLE_Close() As String 60| 61| On Error GoTo Err_ 62| PS_App.Quit 63| Set PS_App = Nothing 64| 65| Exit_: 66| Exit Function 67| Err_: 68| PS_OLE_Close = "PS_OLE_Close = Error Nr: " & Err.Number & vbNewLine & Err.Description 69| Resume Exit_ 70| 71| End Function 72| 73| 74| 75| Public Function PS_OpenDocument(Fullpath As String) As String 76| 77| On Error Resume Next 78| 'On Error GoTo Err_ 79| PS_Reset() 80| 81| 'build the descriptor 82| PS_Desc.PutPath phKeyNull, Fullpath 83| 84| 'play the event and get the result back 85| Set PS_Result = PS_Control.Play(phEventOpen, PS_Desc, phDialogSilent) 86| 87| 'now check for errors 88| PS_OpenDocument = GetErrorStringFromDescriptor(PS_Result,"PS_OpenDocument",True) 89| 90| Exit_: 91| Exit Function 92| Err_: 93| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 94| Resume Exit_ 95| 96| End Function 97| 98| 99| Public Function PS_CloseDocument() As String 100| On Error Resume Next 101| 'On Error GoTo Err_ 102| PS_Reset() 103| 104| 'play the event and get the result back 105| Set PS_Result = PS_Control.Play(phEventClose, Nothing, phDialogSilent) 106| 107| 'now check for errors 108| PS_CloseDocument = GetErrorStringFromDescriptor(PS_Result,"PS_CloseDocument",True) 109| 110| 111| Exit_: 112| Exit Function 113| Err_: 114| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 115| Resume Exit_ 116| 117| End Function 118| 119| 120| Public Function PS_SaveFile(Optional FullOrRelativePath As String = "") As String 121| On Error Resume Next 122| 'On Error GoTo Err_ 123| PS_Reset() 124| 125| If FullOrRelativePath <> "" Then 126| ' Save the current file in PSD-format with different Path 127| PS_Desc.PutPath phKeyIn, FullOrRelativePath 128| Set PS_Result = PS_Control.Play(phEventSave, PS_Desc, phDialogSilent) 129| Else 130| ' Save the current file as PSD-file 131| Set PS_Result = PS_Control.Play(phEventSave, Nothing, phDialogSilent) 132| End If 133| 134| 'now check for errors 135| PS_SaveFile = GetErrorStringFromDescriptor(PS_Result,"PS_SaveFile",True) 136| 137| Exit_: 138| Exit Function 139| Err_: 140| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 141| Resume Exit_ 142| 143| End Function 144| 145| Public Function PS_SaveFileAsPSD(Fullpath As String) As String 146| 147| On Error Resume Next 148| 'On Error GoTo Err_ 149| PS_Reset() 150| 151| 152| ' Set Params for PSD-Format 153| 154| ' build the descriptor 155| PS_Desc.PutObject phKeyAs, phClassPhotoshop35Format, PS_Params 156| PS_Desc.PutBoolean phKeyAlphaChannels, True 157| PS_Desc.PutBoolean phKeyLayers, True 158| PS_Desc.PutPath phKeyIn, Fullpath 159| PS_GlobalFileSaveOptions 160| 161| 162| Set PS_Result = PS_Control.Play(phEventSave, PS_Desc, phDialogSilent) 163| 164| 'now check for errors 165| PS_SaveFileAsPSD = GetErrorStringFromDescriptor(PS_Result,"PS_SaveFileAsPSD",True) 166| 167| Exit_: 168| Exit Function 169| Err_: 170| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 171| Resume Exit_ 172| 173| End Function 174| 175| 176| Public Function PS_SaveFileAsJPG(SourceFileFormat As String,Fullpath As String, Quality As Long, Optimized As Boolean, Optional Scans As Long = 0) As String 177| 178| On Error Resume Next 179| 'On Error GoTo Err_ 180| If UCase(SourceFileFormat) = "PSD" Then 181| PS_Reset() 182| PS_FlattenImage 183| End If 184| PS_Reset() 185| 186| 187| DoDbgMsg(medium,"PS_SaveFileAsJPG",FunctionEntry,"Quality: " & Quality & vbCr & "optimized: " & Optimized & vbCr & "Scans: " & Scans) 188| 189| ' Set Params for JPEG-Format 190| 'PS_Params.PutInteger phKeyQuality, Quality 191| PS_Params.PutInteger phKeyExtendedQuality, Quality 192| If Optimized And Scans < 3 Then 193| PS_Params.PutBoolean phKeyOptimized, Optimized 194| End If 195| If Scans = 3 Or Scans = 4 Or Scans = 5 Then 196| PS_Params.PutInteger phKeyScans, Scans 197| End If 198| 199| ' build the descriptor 200| PS_Desc.PutObject phKeyAs, phClassJPEGFormat, PS_Params 201| PS_Desc.PutPath phKeyIn, Fullpath 202| PS_GlobalFileSaveOptions 203| 204| Set PS_Result = PS_Control.Play(phEventSave, PS_Desc, phDialogSilent) 205| 206| 'now check for errors 207| PS_SaveFileAsJPG = GetErrorStringFromDescriptor(PS_Result,"PS_SaveFileAsJPG",True) 208| 209| Exit_: 210| Exit Function 211| Err_: 212| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 213| Resume Exit_ 214| 215| End Function 216| 217| 218| Public Function PS_SaveFileAsTIF(SourceFileFormat As String,Fullpath As String, Optional ByteOrder As PS_ByteOrder = phEnumIBMPC, Optional LZWComp As Boolean = False) As String 219| 220| On Error Resume Next 221| 'On Error GoTo Err_ 222| If UCase(SourceFileFormat) = "PSD" Then 223| PS_Reset() 224| PS_FlattenImage 225| End If 226| PS_Reset() 227| 228| ' Set Params for TIFF-Format 229| PS_Params.PutBoolean phKeyLZWCompression, LZWComp 230| PS_Params.PutEnumerated phKeyByteOrder, phTypePlatform, ByteOrder 231| 232| 'build the descriptor 233| PS_Desc.PutObject phKeyAs, phClassTIFFFormat, PS_Params 234| PS_Desc.PutPath phKeyIn, Fullpath 235| PS_GlobalFileSaveOptions 236| 237| 'play the event and get the result back 238| Set PS_Result = PS_Control.Play(phEventSave, PS_Desc, phDialogSilent) 239| 240| 241| 'now check for errors 242| PS_SaveFileAsTIF = GetErrorStringFromDescriptor(PS_Result,"PS_SaveFileAsTIF",True) 243| 244| Exit_: 245| Exit Function 246| Err_: 247| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 248| Resume Exit_ 249| 250| End Function 251| 252| 253| Public Function PS_SaveFileAsEPS(SourceFileFormat As String, Fullpath As String, Optional Preview As PS_epsPreview = phEnumTIFF, Optional Depth As PS_epsDepth = phEnum8BitsPerPixel, Optional Encoding As PS_epsEncoding = phEnumBinary, Optional EncodingJPEGQuality As PS_epsEncodingJPEGQuality = phEnumMaximumQuality, Optional HalftoneScreen As Boolean = False, Optional Transfer As Boolean = False, Optional ColorManagement As Boolean = False) As String 254| On Error Resume Next 255| 'On Error GoTo Err_ 256| If UCase(SourceFileFormat) = "PSD" Then 257| PS_Reset() 258| PS_FlattenImage 259| End If 260| PS_Reset() 261| 262| 263| ' Set Params for JPEG-Format 264| If Not Preview = None Then 265| PS_Params.PutEnumerated phKeyPreview, phTypeEPSPreview, Preview 266| PS_Params.PutEnumerated phKeyDepth, phTypeDepth, Depth 267| End If 268| PS_Params.PutEnumerated phKeyEncoding, phTypeEncoding, Encoding 269| If Encoding = phEnumJPEG Then PS_Params.PutEnumerated phKeyQuality, phTypeQuality, EncodingJPEGQuality 270| 271| PS_Params.PutBoolean phKeyHalftoneScreen, HalftoneScreen 272| PS_Params.PutBoolean phKeyTransferFunction, Transfer 273| PS_Params.PutBoolean phKeyColorManagement, ColorManagement 274| 'PS_Params.PutBoolean phKeyInterfaceIconFrameDimmed, False 275| 276| ' build the descriptor 277| PS_Desc.PutObject phKeyAs, phClassPhotoshopEPSFormat, PS_Params 278| PS_Desc.PutPath phKeyIn, Fullpath 279| PS_GlobalFileSaveOptions 280| 281| 282| Set PS_Result = PS_Control.Play(phEventSave, PS_Desc, phDialogSilent) 283| 284| 'now check for errors 285| PS_SaveFileAsEPS = GetErrorStringFromDescriptor(PS_Result,"PS_SaveFileAsEPS",True) 286| 287| Exit_: 288| Exit Function 289| Err_: 290| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 291| Resume Exit_ 292| 293| End Function 294| 295| 296| 'Function PS_ScaleImage(Width As Double, Height As Double, ConstrainProportions As Boolean, landscape As Boolean, Optional dpi As Integer) As Long 297| Public Function PS_ScaleImage(Width As Double, Height As Double, dpi As Integer, landscape As Boolean, Optional ConstrainProportions As Boolean = True) As String 298| 299| On Error Resume Next 300| 'On Error GoTo Err_ 301| PS_Reset() 302| 303| 'DoDbgMsg(medium,"PS_ScaleImage",FunctionEntry,"Width: " & Width & " | Height: " & Height & " | landscape: " & landscape) 304| 305| 'build the descriptor 306| 'If we have no value for Width and Height, we only want to set a dpi-value without scaling the image 307| If Width > 0 Or Height > 0 Then 308| 309| If ConstrainProportions Then 310| If landscape Then 311| DoDbgMsg(high,"PS_ScaleImage",duringFunctionProcess,"It's a Landscape with ConstrainProperties") 312| PS_Desc.PutUnitDouble phKeyWidth, phUnitPixels, Width 313| PS_Desc.PutBoolean phKeyConstrainProportions, True 314| Else 315| DoDbgMsg(high,"PS_ScaleImage",duringFunctionProcess,"It's NOT a Landscape but with ConstrainProperties") 316| PS_Desc.PutUnitDouble phKeyHeight, phUnitPixels, Height 317| PS_Desc.PutBoolean phKeyConstrainProportions, True 318| End If 319| Else 320| DoDbgMsg(high,"PS_ScaleImage",duringFunctionProcess,"It doesn't ConstrainProperties") 321| PS_Desc.PutUnitDouble phKeyWidth, phUnitPixels, Width 322| PS_Desc.PutUnitDouble phKeyHeight, phUnitPixels, Height 323| End If 324| 325| PS_Desc.PutEnumerated phKeyInterfaceIconFrameDimmed, phTypeInterpolation, phEnumBicubic 326| 327| End If 328| 329| 'set dpi-value 330| PS_Desc.PutUnitDouble phKeyResolution, phUnitDensity, dpi 331| 332| 333| 'play the event and get back the result 334| Set PS_Result = PS_Control.Play(phEventImageSize, PS_Desc, phDialogSilent) 335| 336| 337| 'now check for errors 338| PS_ScaleImage = GetErrorStringFromDescriptor(PS_Result,"PS_ScaleImage",True) 339| 340| Exit_: 341| Exit Function 342| Err_: 343| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 344| Resume Exit_ 345| 346| End Function 347| 348| 349| Public Function PS_ICC_Assign(AssignICCProfile As String) As String 350| 351| On Error Resume Next 352| 'On Error GoTo Err_ 353| PS_Reset() 354| 355| 356| Dim temp As String 357| Dim PS_typeid As Long 358| Dim PS_Ref As IActionReference 359| 360| Set PS_Ref = PS_App.MakeReference 361| 362| PS_Ref.PutEnumerated(phClassDocument, phTypeOrdinal, phEnumTarget) 363| PS_Desc.PutReference(phKeyNull, PS_Ref) 364| PS_Control.StringIDToTypeID("profile",PS_typeid) 365| PS_Desc.PutString(PS_typeid,AssignICCProfile) 366| PS_Desc.PutEnumerated(phKeyIntent,phTypeIntent,phEnumImage) 367| PS_Control.StringIDToTypeID("assignProfile",PS_typeid) 368| 369| 370| Set PS_Result = PS_Control.Play(PS_typeid, PS_Desc, phDialogSilent) 371| 372| 'now check for errors 373| PS_ICC_Assign = GetErrorStringFromDescriptor(PS_Result,"PS_ICC_Assign",True) 374| 375| Exit_: 376| Exit Function 377| Err_: 378| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 379| Resume Exit_ 380| 381| End Function 382| 383| 384| Public Function PS_ICC_Conversion(TargetICCProfile As String) As String 385| 386| On Error Resume Next 387| On Error GoTo Err_ 388| PS_Reset() 389| 390| Dim temp As String 391| Dim PS_typeid As Long 392| Dim PS_Ref As IActionReference 393| 394| Set PS_Ref = PS_App.MakeReference 395| 396| PS_Ref.PutEnumerated(phClassDocument, phTypeOrdinal, phEnumTarget) 397| PS_Desc.PutString(phKeyTo,TargetICCProfile) 398| PS_Desc.PutEnumerated(phKeyIntent,phTypeIntent,phEnumImage) 399| PS_Desc.PutBoolean(phKeyMapBlack,1) 400| PS_Desc.PutBoolean(phKeyDither, 1) 401| PS_Desc.PutReference(phKeyNull, PS_Ref) 402| PS_Control.StringIDToTypeID("convertToProfile",PS_typeid) 403| 404| 'PS_Desc.GetString(phKeyTo,temp) 405| 'MsgBox temp 406| 407| 'MsgBox Str(PS_typeid) 408| 409| Set PS_Result = PS_Control.Play(PS_typeid, PS_Desc, phDialogSilent) 410| 411| 'now check for errors 412| PS_ICC_Conversion = GetErrorStringFromDescriptor(PS_Result,"PS_ICC_Conversion",True) 413| 414| Exit_: 415| Exit Function 416| Err_: 417| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 418| Resume Exit_ 419| 420| End Function 421| 422| 423| 424| Function PS_ConvertColorMode(NewMode As PS_DefaultColorspaces) As String 425| 426| On Error Resume Next 427| 'On Error GoTo Err_ 428| PS_Reset() 429| 430| 'build the descriptor 431| PS_Desc.PutClass phKeyTo, NewMode 432| 433| 'play the event and get back the result 434| Set PS_Result = PS_Control.Play(phEventConvertMode, PS_Desc, phDialogSilent) 435| 436| 'now check for errors 437| PS_ConvertColorMode = GetErrorStringFromDescriptor(PS_Result,"PS_ConvertColorMode",True) 438| 439| Exit_: 440| Exit Function 441| Err_: 442| 'MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 443| Resume Exit_ 444| 445| End Function 446| 447| 448| Public Sub PS_FlattenImage 449| Set PS_Result = PS_Control.Play(phEventFlattenImage, Nothing, phDialogSilent) 450| End Sub 451| 452| 453| Public Function PS_GetActionNames(App As PhotoshopApplication,ByRef actlist() As String) As Integer 454| On Error GoTo Err_ 455| 456| Dim k As Integer 457| 458| Application.OLEServerBusyTimeout = OLE_TimeOut 459| 460| If App Is Nothing Then 461| PS_GetActionNames = -1 462| GoTo Exit_ 463| End If 464| 465| k = 0 466| For Each PS_Action In App.Actions 'Dieser kram laesst sich nur 1x aufrufen, sonst crashed ps... 467| actlist(k) = PS_Action.Name 468| k = k+1 469| Next 470| 471| ReDim Preserve actlist( k ) 472| 473| PS_GetActionNames = k 474| 475| Exit_: 476| Exit Function 477| Err_: 478| MsgBox "Error Nr: " & Err.Number & vbNewLine & Err.Description 479| Resume Exit_ 480| 481| End Function 482| 483| 484| Public Function GetAppInfoStructureFromPS() As PSAppInfo 485| 486| Dim result As IActionDescriptor 487| Dim inf As PSAppInfo 488| Dim k As Long 489| Dim s As String 490| Dim typeid As Long 491| 492| Set result = GetInfoFromPhotoshop(PS_App,PS_Control,phClassApplication,phKeyFileSavePrefs) 493| PS_Control.StringIDToTypeID("advancedTIFF",typeid) 494| result.GetBoolean(typeid,k) 495| inf.SaveAdvancedTiff = k 496| 497| Set result = GetInfoFromPhotoshop(PS_App,PS_Control,phClassApplication, phKeyCachePrefs) 498| result.GetInteger(phKeyMemoryUsagePercent,inf.MemoryUsagePercent) 499| 500| Set result = GetInfoFromPhotoshop(PS_App,PS_Control,phClassApplication,phKeyFileSavePrefs) 501| result.GetBoolean(phKeySaveComposite,k) 502| inf.SaveComposite = k 503| 504| 505| 'PS_Control.StringIDToTypeID("colorSettings",typeid) 506| 'Set result = GetInfoFromPhotoshop(PS_App,PS_Control,phClassApplication,typeid) 507| 'result.GetString(phKeyName,s) 508| 'inf.ColorSettings = s 509| 510| inf.openDocs = GetInfoFromPhotoshop(PS_App,PS_Control,phClassApplication,phKeyNumberOfDocuments) 511| 512| 513| GetAppInfoStructureFromPS = inf 514| 515| End Function 516| 517| 518| 519| ' Given a class and property the GetActionProperty will 520| ' return a descriptor with the information in it. This 521| ' routine pulls open that descriptor and returns the 522| ' data for you. This uses VB's Variant technology to 523| ' return any type for you. 524| Private Function GetInfoFromPhotoshop(PSApp As PhotoshopApplication, gControl As IActionControl, Class_ As Long, Property_ As Long) As Variant 525| 526| Dim reference As IActionReference 527| Dim result As IActionDescriptor 528| Dim hasKey As Long 529| Dim keyType As Long 530| Dim unitID As Long 531| ' All the return types available 532| Dim longValue As Long 533| Dim doubleValue As Double 534| Dim stringValue As String 535| Dim boolValue As Long 536| Dim descValue As IActionDescriptor 537| Dim enumValue As Long 538| Dim listValue As IActionList 539| Dim refValue As IActionReference 540| 541| 542| On Error Resume Next 543| 544| 545| If Property_ > 0 Then 546| Set reference = PSApp.MakeReference 547| 548| 549| reference.PutProperty phClassProperty, Property_ 550| reference.PutEnumerated Class_, phTypeOrdinal, phEnumTarget 551| 552| 553| gControl.GetActionProperty reference, result 554| 555| 556| result.HasKey Property_, hasKey 557| 558| 559| If hasKey Then 560| result.GetType Property_, keyType 561| Select Case (keyType) 562| Case phTypeInteger 563| result.GetInteger Property_, longValue 564| GetInfoFromPhotoshop = longValue 565| 566| 567| Case phTypeFloat 568| result.GetDouble Property_, doubleValue 569| GetInfoFromPhotoshop = doubleValue 570| 571| 572| Case phTypeUnitFloat 573| result.GetUnitDouble Property_, unitID, doubleValue 574| GetInfoFromPhotoshop = doubleValue 575| 576| 577| Case phTypeChar 578| result.GetString Property_, stringValue 579| GetInfoFromPhotoshop = stringValue 580| 581| 582| Case phTypePath 583| result.GetPath Property_, stringValue 584| GetInfoFromPhotoshop = stringValue 585| 586| 587| Case phTypeBoolean 588| result.GetBoolean Property_, boolValue 589| GetInfoFromPhotoshop = boolValue 590| 591| 592| Case phTypeObject 593| result.GetObject Property_, unitID, descValue 594| Set GetInfoFromPhotoshop = descValue 595| 596| 597| Case phTypeGlobalObject 598| result.GetGlobalObject Property_, unitID, descValue 599| Set GetInfoFromPhotoshop = descValue 600| 601| 602| Case phTypeEnumerated 603| result.GetEnumerated Property_, unitID, enumValue 604| GetInfoFromPhotoshop = enumValue 605| 606| 607| Case phTypePath, phTypeAlias 608| result.GetPath Property_, stringValue 609| GetInfoFromPhotoshop = stringValue 610| 611| 612| Case phTypeValueList 613| result.GetList Property_, listValue 614| Set GetInfoFromPhotoshop = listValue 615| 616| 617| Case phTypeObjectSpecifier 618| result.GetReference Property_, refValue 619| Set GetInfoFromPhotoshop = refValue 620| 621| 622| Case phTypeType, phTypeGlobalClass 623| result.GetClass Property_, unitID 624| GetInfoFromPhotoshop = unitID 625| 626| 627| Case Else 628| GetInfoFromPhotoshop = "Unsupported type: GetInfoFromPhotoshop" 629| End Select 630| Else 631| GetInfoFromPhotoshop = "ERROR: Does not have this key." 632| End If 'hasKey 633| Else 634| GetInfoFromPhotoshop = "ERROR: Property must be a positive value." 635| End If 'property > 0 636| End Function 637| 638| 639| Private Function GetErrorStringFromDescriptor(Desc As IActionDescriptor, Optional CallingFuncName As String, Optional DoDebug As Boolean = False) As String 640| 641| GetErrorStringFromDescriptor = "" 642| 643| Dim hasString As Long 644| 645| On Error Resume Next ' i need a way to tell that the desc is nothing 646| 647| GetErrorStringFromDescriptor = "" 648| 'If Not (desc = Nothing) Then 649| Desc.HasKey phKeyMessage, hasString 650| If hasString Then 651| Desc.GetString phKeyMessage, GetErrorStringFromDescriptor 652| End If 653| 'End If 654| 655| If hasString Then 656| GetErrorStringFromDescriptor = CallingFuncName & ": " & GetErrorStringFromDescriptor & vbNewLine 657| If DoDebug Then Debug.Print CallingFuncName & ": " & GetErrorStringFromDescriptor 658| End If 659| 660| End Function 661| 662| 663| Private Sub PS_GlobalFileSaveOptions 664| PS_Desc.PutBoolean phKeyCopy, False 665| PS_Desc.PutBoolean phKeyLowerCase, ffglobal.LowerCase 666| PS_Desc.PutBoolean phKeyEmbedProfiles, ffglobal.EmbedProfiles 667| End Sub 668| 669| 670| Private Function PS_Reset() 671| PS_Params.Clear 672| PS_Desc.Clear 673| Application.OLEServerBusyTimeout = OLE_TimeOut 674| End Function 675| 676| 677| 678| 679| '### FunctionList: 680| ' - Function PS_ConvertColorMode(NewMode As PS_DefaultColorspaces) As String 681| ' - Private Function GetErrorStringFromDescriptor(Desc As IActionDescriptor, Optional CallingFuncName As String, Optional DoDebug As Boolean = False) As String 682| ' - Private Function GetInfoFromPhotoshop(PSApp As PhotoshopApplication, gControl As IActionControl, Class_ As Long, Property_ As Long) As Variant 683| ' - Private Function PS_Reset() 684| ' - Private Sub PS_GlobalFileSaveOptions 685| ' - Public Function GetAppInfoStructureFromPS() As PSAppInfo 686| ' - Public Function PS_CloseDocument() As String 687| ' - Public Function PS_GetActionNames(App As PhotoshopApplication,ByRef actlist() As String) As Integer 688| ' - Public Function PS_ICC_Assign(AssignICCProfile As String) As String 689| ' - Public Function PS_ICC_Conversion(TargetICCProfile As String) As String 690| ' - Public Function PS_OLE_Close() As String 691| ' - Public Function PS_OLE_Start(Optional ByRef Reg As clsRegKey) As String 692| ' - Public Function PS_OpenDocument(Fullpath As String) As String 693| ' - Public Function PS_SaveFile(Optional FullOrRelativePath As String = "") As String 694| ' - Public Function PS_SaveFileAsEPS(SourceFileFormat As String, Fullpath As String, Optional Preview As PS_epsPreview = phEnumTIFF, Optional Depth As PS_epsDepth = phEnum8BitsPerPixel, Optional Encoding As PS_epsEncoding = phEnumBinary, Optional EncodingJPEGQuality As PS_epsEncodingJPEGQuality = phEnumMaximumQuality, Optional HalftoneScreen As Boolean = False, Optional Transfer As Boolean = False, Optional ColorManagement As Boolean = False) As String 695| ' - Public Function PS_SaveFileAsJPG(SourceFileFormat As String,Fullpath As String, Quality As Long, Optimized As Boolean, Optional Scans As Long = 0) As String 696| ' - Public Function PS_SaveFileAsPSD(Fullpath As String) As String 697| ' - Public Function PS_SaveFileAsTIF(SourceFileFormat As String,Fullpath As String, Optional ByteOrder As PS_ByteOrder = phEnumIBMPC, Optional LZWComp As Boolean = False) As String 698| ' - Public Function PS_ScaleImage(Width As Double, Height As Double, dpi As Integer, landscape As Boolean, Optional ConstrainProportions As Boolean = True) As String 699| ' - Public Sub PS_FlattenImage 700| 701| '### Public Declarations: 702|