Skip to content
Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1803 lines (1416 sloc) 90.1 KB
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "pdPSD"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'***************************************************************************
'PhotoDemon PSD (PhotoShop Image) Container and Parser
'Copyright 2019-2019 by Tanner Helland
'Created: 13/January/19
'Last updated: 19/February/19
'Last update: wrap up support for "use max compatibility" feature when exporting PSDs
'
'This class (and its associated pdPSD- child classes) handle Adobe PSD parsing duties. It is custom-built
' for PhotoDemon, with an emphasis on performance and proper color-management of all imported data.
'
'To my knowledge, this is the only 3rd-party PSD parser that passes the full Apple color management
' test suite (https://developer.apple.com/library/archive/technotes/tn2115/_index.html). This is a large
' point of pride for the author. ;)
'
'Currently, all color modes (nine in the spec), and all color depths (1 through 32-bits-per-channel)
' are believed to be fully covered by the import engine. The export engine, by design, only writes
' 32-bpp RGBA images (as this is all PhotoDemon itself supports internally), but supporting other
' color modes or depths would require only minor modifications.
'
'As with all 3rd-party PSD engines, Photoshop has many features that don't have direct analogs in PhotoDemon.
' Such features are still extracted by this class, but they will not "appear" in the final loaded image.
' My ongoing goal is to expand support in this class as various PSD features are implemented in PD itself.
'
'Unless otherwise noted, all code in this class is my original work. I've based my work off the
' "official" Adobe spec at this URL (link good as of January 2019):
' https://www.adobe.com/devnet-apps/photoshop/fileformatashtml/#50577409_72092
'
'In places where Adobe's spec is either out-of-date or purely inaccurate, the open-source, MIT-licensed
' Paint.NET PSD plugin proved to be a valuable resource. Its source code is available here
' (link good as of January 2019):
' https://github.com/PsdPlugin/PsdPlugin
'
'All source code in this file is licensed under a modified BSD license. This means you may use the code in your own
' projects IF you provide attribution. For more information, please visit https://photodemon.org/license/
'
'***************************************************************************
Option Explicit
'PSD files contain a *lot* of information. To aid debugging, you can activate "verbose" output; this will
' dump all kinds of diagnostic information to the debug log. (Note that other PSD-adjacent classes have
' their own version of this constant.)
Private Const PSD_DEBUG_VERBOSE As Boolean = False
'PSD loading is complicated, and a lot of things can go wrong. Instead of returning binary "success/fail"
' values, we return specific flags; "warnings" may be recoverable and you can still attempt to load the file.
' "Failure" returns are unrecoverable and processing *must* be abandoned. (As a convenience, you can treat
' the "warning" and "failure" values as flags; specific warning/failure states in each category will share
' the same high flag bit.)
'
'As I get deeper into this class, I may expand this enum to include more detailed states.
Public Enum PD_PSDResult
psd_Success = 0
psd_Warning = 256
psd_Failure = 65536
psd_FileNotPSD = 16777217
End Enum
#If False Then
Private Const psd_Success = 0, psd_Warning = 256, psd_Failure = 65536, psd_FileNotPSD = 16777217
#End If
'PSDs support many different color modes. Some color modes (e.g. Duotone) are proprietary and not
' publicly documented; we follow Adobe's recommendation and simply load the data in an alternative format
' (e.g. grayscale in the case of Duotone).
Public Enum PSD_ColorMode
cm_Bitmap = 0
cm_Grayscale = 1
cm_Indexed = 2
cm_RGB = 3
cm_CMYK = 4
cm_Multichannel = 7
cm_Duotone = 8
cm_Lab = 9
End Enum
#If False Then
Private Const cm_Bitmap = 0, cm_Grayscale = 1, cm_Indexed = 2, cm_RGB = 3, cm_CMYK = 4, cm_Multichannel = 7, cm_Duotone = 8, cm_Lab = 9
#End If
'The list of potential resource IDs is enormous:
' https://www.adobe.com/devnet-apps/photoshop/fileformatashtml/#50577409_38034
' Most of these are irrelevant to PD, so for now, I've only listed ones that look potentially useful.
Private Enum PSD_ResourceID
rid_ResolutionInfo = 1005
rid_Caption = 1008
rid_BackgroundColor = 1010 'Old PS versions required a background layer, if any, to be opaque
rid_QuickMaskInfo = 1022 'Not sure if this needs to be used during compositing
rid_LayerStateInfo = 1024 'Could be useful for determining auto-selected layer
rid_LayersGroupInfo = 1026 'Could be useful for IDing and removing group-specific blank layers
rid_IptcMetadata = 1028 'Compare against ExifTool's results?
rid_JpegQuality = 1030 'We could auto-suggest this if saving as a JPEG from PD?
rid_GridAndGuidesInfo = 1032 'Guides are on my to-do list
rid_IccProfile = 1039 'Speaks for itself; this is critical to PD's color-managed import process
rid_IccUntagged = 1041 'Spec is unclear on what this means; I'd need to see it "in the wild" to know how to handle in PD
rid_IndexedColorTableCount = 1046 'Number of used colors - important for indexed images!
rid_TransparentIndex = 1047 'Need to test against an indexed image PSD
rid_AlphaIdentifiers = 1053 'No idea what this does, but we should check it against alpha channels
rid_VersionInfo = 1057 'Lets us know if PS was the actual image source; will need to write when saving
rid_EXIFData1 = 1058 'Check integration w/ ExifTool
rid_EXIFData3 = 1059 'Check integration w/ ExifTool
rid_XMPMetadata = 1060 'Check integration w/ ExifTool
rid_PixelAspectRatio = 1064 'Could theoretically correct for this
rid_LayerSelectionIDs = 1069 'Possibly useful if understood
rid_LayerGroupsEnabledID = 1072 'Probably need this to decode layer group behavior
rid_MeasurementScale = 1074 'Could potentially auto-adjust rulers against this? idk
rid_DisplayInfo = 1077 '"DisplayInfo structure to support floating point colors. See Appendix A in Photoshop API Guide.pdf"
rid_PathInfo = 2000 'Actually comprises 2000-2997; could be useful in the future
rid_ClippingPathName = 2999 'We could potentially support this, if found
End Enum
#If False Then
Private Const rid_ResolutionInfo = 1005, rid_Caption = 1008, rid_BackgroundColor = 1010, rid_QuickMaskInfo = 1022, rid_LayerStateInfo = 1024, rid_LayersGroupInfo = 1026, rid_IptcMetadata = 1028, rid_JpegQuality = 1030, rid_GridAndGuidesInfo = 1032, rid_IccProfile = 1039, rid_IccUntagged = 1041, rid_IndexedColorTableCount = 1046, rid_TransparentIndex = 1047, rid_AlphaIdentifiers = 1053, rid_VersionInfo = 1057, rid_EXIFData1 = 1058, rid_EXIFData3 = 1059, rid_XMPMetadata = 1060, rid_PixelAspectRatio = 1064, rid_LayerSelectionIDs = 1069, rid_LayerGroupsEnabledID = 1072, rid_MeasurementScale = 1074, rid_DisplayInfo = 1077, rid_PathInfo = 2000, rid_ClippingPathName = 2999
#End If
'Standard PSD header. At load-time, only populated if the target PSD validates.
' (Note that this struct has major alignment issues under VB if attempting to write the whole thing
' as a block; PD writes members individually to avoid these issues.
Private Type PSD_Header
Signature As String * 4
Version As Integer
Reserved(0 To 5) As Byte
NumChannels As Integer
ImageHeightPx As Long
ImageWidthPx As Long
BitsPerChannel As Integer
ColorMode As PSD_ColorMode
End Type
Private m_Header As PSD_Header
'If the header defines a PSB file instead of a PSD file, this value will be set to TRUE early in the parse process.
' Subsequent functions should use this value to modify behavior according to PSD/PSB differences.
Private m_PSDisPSB As Boolean
'PhotoShop uses a detailed struct for resolution info; the spec tells you to dive into the separate
' SDK guide for this info, which is obtainable from https://www.adobe.com/devnet/photoshop/sdk.html
Private Enum PSD_ResolutionUnit
ruInches = 1
ruCentimeters = 2
ruPoints = 3
ruPicas = 4
ruColumns = 5
End Enum
#If False Then
Private Const ruInches = 1, ruCentimeters = 2, ruPoints = 3, ruPicas = 4, ruColumns = 5
#End If
'Per the spec:
' 1=display [sic] horitzontal resolution in pixels per inch; 2=display [sic] horitzontal resolution in pixels per cm.
Private Enum PSD_ResolutionUnitDisplay
rudPPI = 0
rudPPCm = 1
End Enum
#If False Then
Private Const rudPPI = 0, rudPPCm = 1
#End If
Private Type PSD_ResolutionInfo
riHRes As Single 'Fixed32 in the file
riHResUnit As PSD_ResolutionUnitDisplay 'Integer in the file
riWidthUnit As PSD_ResolutionUnit 'Integer in the file
riVRes As Single 'Fixed32 in the file
riVResUnit As PSD_ResolutionUnitDisplay 'Integer in the file
riHeightUnit As PSD_ResolutionUnit 'Integer in the file
End Type
Private m_ResolutionInfo As PSD_ResolutionInfo
'If the PSD file uses indexed color mode, its palette will be initialized into this array
Private m_ColorTable() As RGBQuad, m_ColorTableCount As Long, m_TransparentIndex As Long
'Any stored image resources are retrieved as-is. Some of these may be parsed further
' and stored in specialized (more usable) types.
Private Type PSD_ImageResource
'irSignature As String * 4 'Always '8BIM', so we don't waste bytes storing it
irID As PSD_ResourceID '2-byte hex ID
irName As String 'Pascal string, always "null" IRL as far as I can tell
irDataLength As Long 'Size of data array
irDataBytes() As Byte '"Padded to make the size even"; PD will *not* retrieve padding bytes if they occur
End Type
Private m_ImageResources() As PSD_ImageResource
Private m_NumImageResources As Long
'If the PSD file contains layers (null-layer images *are* technically possible), each layer's contents
' will be accessible from this array. If m_NumOfLayers is non-zero, this array is guaranteed to be sized
' as (0 to Abs(m_NumOfLayers) - 1).
Private m_Layers() As pdPSDLayer
'Per the spec, the number of layers *CAN BE NEGATIVE*. A negative count has special meaning; see Step 4 for details.
Private m_numOfLayers As Long
'Embedded ICC profiles are read and used by PD. (These can be found in the "image resource" segment.)
Private m_Profile As pdICCProfile
'Byte-by-byte access is provided, as always, by a pdStream instance
Private m_Stream As pdStream
'At present, we require the caller to pass an identical source file path to every load function.
' (This is a cheap and easy way to ensure no funny business.) If the PSD is loaded directly from memory,
' we flag this with a special name.
Private m_SourceFilename As String
Private Const PSD_LOADED_FROM_MEMORY As String = "LoadFromPtr*"
Private m_SourcePtr As Long, m_SourcePtrLen As Long
'If warnings are encountered during processing, I push their messages onto a string stack. (I may
' decide to report these to the user... but haven't decided yet. Either way, it's very helpful
' while debugging; see associated Warnings_XYZ functions for details.)
Private m_Warnings As pdStringStack
'Perform basic validation on a potential PSD file. For strict file extension matching (e.g. only
' PSD or PSB extension allowed), set checkExtension to TRUE.
Friend Function IsFilePSD(ByRef srcFile As String, Optional ByVal checkExtension As Boolean = False) As Boolean
IsFilePSD = (Step1_ValidateHeader(srcFile, checkExtension) < psd_Failure)
End Function
'Simplified wrapper to load a PSD automatically.
Friend Function LoadPSD(ByRef srcFile As String, ByRef dstImage As pdImage, ByRef dstDIB As pdDIB, Optional ByVal checkExtension As Boolean = False, Optional ByVal loadFromPtr As Long = 0, Optional ByVal loadFromPtrLen As Long = 0) As PD_PSDResult
'Reset some internal parameters to ensure subsequent reads are accurate. (This is critical if multiple PSDs
' are read back-to-back.)
Me.Reset
'We support PSD loading from both file and memory; if the passed loadFromPtr value is non-zero,
' treat it as a pointer and we'll wrap our stream around it instead.
If (loadFromPtr <> 0) And (loadFromPtrLen <> 0) Then
srcFile = PSD_LOADED_FROM_MEMORY
m_SourcePtr = loadFromPtr
m_SourcePtrLen = loadFromPtrLen
Else
m_SourcePtr = 0
m_SourcePtrLen = 0
End If
'Try to validate the source file
Dim keepLoading As PD_PSDResult
keepLoading = Step1_ValidateHeader(srcFile, checkExtension, True)
If (keepLoading < psd_Failure) Then
'The file validated well enough to continue (e.g. any warnings were considered non-fatal).
' Further processing is handled on a block-by-block basis, and a critical error at any step
' causes the entire file to be abandoned.
PDDebug.LogAction "PSD file detected. Size is " & m_Header.ImageWidthPx & "x" & m_Header.ImageHeightPx & ", color mode is " & GetColorModeName(m_Header.ColorMode) & ", " & m_Header.BitsPerChannel & " bits per channel."
keepLoading = Step2_RetrieveColorModeData(srcFile)
If PSD_DEBUG_VERBOSE Then If (keepLoading < psd_Failure) Then PDDebug.LogAction "PSD parsing step 2 successful." Else PDDebug.LogAction "PSD parsing step 2 unsuccessful."
'The color table, if any, has been retrieved. The next segment of the file is a massive chunk
' called "Image Resources". Much of the data in this section is specific to Photoshop, but we will
' attempt to retrieve what we can from it.
If (keepLoading < psd_Failure) Then
keepLoading = Step3_GatherImageResources(srcFile, dstImage)
If PSD_DEBUG_VERBOSE Then If (keepLoading < psd_Failure) Then PDDebug.LogAction "PSD parsing step 3 successful." Else PDDebug.LogAction "PSD parsing step 3 unsuccessful."
End If
'Image resources have been retrieved. The next segment of the file is layer data!
If (keepLoading < psd_Failure) Then
keepLoading = Step4_GatherLayersAndMasks(srcFile)
If PSD_DEBUG_VERBOSE Then If (keepLoading < psd_Failure) Then PDDebug.LogAction "PSD parsing step 4 successful." Else PDDebug.LogAction "PSD parsing step 4 unsuccessful."
End If
'The final segment of a PSD file is a full copy of the composited layered image. When Photoshop writes
' a PSD file, the contents of this segment are tied to a "maximize compatibility" setting. If "maximize
' compatibility" is checked (default = true), a full copy of the composited image is written out to the
' final block of the file. If "maximize compatibility" is *not* set, PhotoShop writes out a plain white
' image to that final segment - a strange decision, but pure white compresses well and this guarantees
' that "lazy" readers still have something to read.
'Anyway, we don't need this data in PD so we ignore it at present. You could, however, parse it as the
' final stage in the load process, if desired - but note that there are caveats to the data in this segment.
' (For example, Photoshop may choose to write some single-layer images as zero-layer images, with the image
' data actually stored in the composited image segment. PhotoDemon supports this condition, so the current
' stream point may not point where you think it does - consider yourself warned!)
'If we made it this far successfully, we have enough data to construct a pdImage object!
If (keepLoading < psd_Failure) Then
'Because the stream object may have pre-cached the PSD file (useful for perf improvements when the source
' data is small), let's free it to free up as much memory as possible before we attempt to assemble the
' final image.
Set m_Stream = Nothing
keepLoading = Step5_AssemblePDImage(srcFile, dstImage)
If PSD_DEBUG_VERBOSE Then If (keepLoading < psd_Failure) Then PDDebug.LogAction "PSD parsing step 5 successful." Else PDDebug.LogAction "PSD parsing step 5 unsuccessful."
End If
LoadPSD = keepLoading
End If
'Even if the PSD loaded, one (or more) surprises may have affected our ability to render everything correctly.
' Regardless of this class's debug verbosity setting, warnings always get dumped out to the debug log. This is
' especially useful when new versions of Photoshop release, as they often bring new parsing surprises/nightmares.
If (Me.Warnings_GetCount() > 0) Then
PDDebug.LogAction "PhotoDemon's PSD parser generated one or more warnings. Here is a full list:"
Me.Warnings_DumpToDebugger
End If
End Function
'Save a new PSD file to disk. (With minor modifications, this could also be used to save to a memory stream,
' but this is *not* currently implemented.)
'
'If the destination file exists, it will be forcibly overwritten. Safe save measures should be implemented externally.
Friend Function SavePSD(ByRef srcPDImage As pdImage, ByVal dstFile As String, Optional ByVal useMaxCompatibility As Boolean = True, Optional ByVal compressionType As Long = 0, Optional ByVal writePSB As Boolean = False) As Boolean
On Error GoTo CouldNotSaveFile
If (srcPDImage Is Nothing) Or (LenB(dstFile) = 0) Then
InternalError "SavePSD", "invalid function parameters"
SavePSD = False
Exit Function
End If
'Failsafe check only; PD enforces save overwriting in the parent function.
If Files.FileExists(dstFile) Then Files.FileDelete dstFile
'So, a few quick notes before we begin.
'1) Saving a PSD file is much easier than loading it, primarily because we don't need to cover every
' color-mode and bit-depth option. Instead, we focus on exporting 32-bit RGBA data in the cleanest
' manner possible. Other bit-depths and/or color modes may be covered in future updates.
'2) PSDs use a ton of structs with non-DWORD alignments. This causes issues in VB6 as struct members
' are typically aligned to DWORD boundaries (with some caveats; it's complicated and basically don't
' worry about it if you aren't a VB6 developer). To avoid complications or convoluted struct-shifting,
' this function manually writes out most struct members individually.
'3) This code was designed against the latest PSD spec at the time of its writing (August 2016,
' available here: https://www.adobe.com/devnet-apps/photoshop/fileformatashtml/). No guarantee is
' made that this approach will be compatible with earlier or later spec versions.
'4) If padding issues with strings (or any other data type) seem messy, that's because they are.
' Adobe uses many different string alignment/padding practices throughout PSDs, and only by a careful
' reading of the spec can you seewhat is required where. Any messiness is their doing - not mine.
'5) All PSD data is big-endian, so you will see a ton of _BE suffixes in stream function calls.
'All good? Then let's do this!
'As usual, all writing is handled by a pdStream instance. Note that we do not request typical
' sequential perf-optimized mode - this is because PSDs use a ton of "length" entries that describe
' following data segments. Lengths are not easily known in advance, so the writer must periodically
' "retreat" and update previous length entries. This incurs potentially huge penalties when
' sequential mode is requested, and random-access shows no meaningful benefit, so we stick to
' default caching behavior.
Dim cStream As pdStream
Set cStream = New pdStream
cStream.StartStream PD_SM_FileBacked, PD_SA_ReadWrite, dstFile
'Start by writing out a basic PSD header.
Dim keepGoing As PD_PSDResult
keepGoing = ExportStep1_WriteHeaderAndColorTable(cStream, srcPDImage, useMaxCompatibility, writePSB)
'Next comes the image resource segment. This is a variable-length segment comprised of individual "blocks".
' Blocks are similar to chunks in other formats; they are self-contained descriptors of variable length
' and type. We write much fewer of these than Photoshop typically does, obviously.
If (keepGoing < psd_Failure) Then keepGoing = ExportStep2_WriteImageResources(cStream, srcPDImage, useMaxCompatibility, writePSB)
'Next comes the (potentially very large) layer and mask information section. This is the most time-consuming
' segment to write, on account of writing all layer pixel data.
If (keepGoing < psd_Failure) Then keepGoing = ExportStep3_WriteLayerAndMaskInformation(cStream, srcPDImage, compressionType, writePSB)
'Finally, if "maximum compatibility" is selected, write out a copy of the merged image data.
If (keepGoing < psd_Failure) Then keepGoing = ExportStep4_WriteMergedImage(cStream, srcPDImage, compressionType, useMaxCompatibility, writePSB)
'The write is finished. Close the file handle and exit.
cStream.StopStream
Set cStream = Nothing
SavePSD = (keepGoing < psd_Failure)
Exit Function
CouldNotSaveFile:
InternalError "SavePSD", "Internal VB error #" & Err.Number & ": " & Err.Description
SavePSD = False
End Function
Private Function ExportStep4_WriteMergedImage(ByRef cStream As pdStream, ByRef srcImage As pdImage, Optional ByVal compressionType As Long = 0, Optional ByVal useMaxCompatibility As Boolean = True, Optional ByVal writePSB As Boolean = False) As PD_PSDResult
'Start by retrieving a merged image copy
Dim tmpDIB As pdDIB
If useMaxCompatibility Then
srcImage.GetCompositedImage tmpDIB, False
'When "max compatibility" is *not* set in Photoshop, Adobe just embeds a blank white image at the size of the
' original image. This compresses much better and allows 3rd-party decoders to still retrieve *something*
' without crashing, and if a program can read layer data anyway, the composite is just a waste of space.
' (See also: https://feedback.photoshop.com/photoshop_family/topics/maximize_file_compatibility_bloats_files_need_smaller_option)
' We mimic Adobe's approach.
Else
Set tmpDIB = New pdDIB
tmpDIB.CreateBlank srcImage.Width, srcImage.Height, 32, vbWhite
End If
'Determine if the composite image has meaningful alpha values (e.g. if it is *not* fully opaque)
Dim alphaMatters As Boolean
alphaMatters = DIBs.IsDIBTransparent(tmpDIB)
'Write the compression method first. Note that only raw and PackBits are currently supported in the
' merged image data segment; PD *could* technically write zipped data, but the spec is unclear on how
' the zip stream is handled in this segment - and it wouldn't be compatible with most applications
' anyway which defeats the whole point of the "maximize compatibility" setting!
Const PSD_COMPRESSION_PACKBITS As Long = 1
If (compressionType > PSD_COMPRESSION_PACKBITS) Then compressionType = PSD_COMPRESSION_PACKBITS
cStream.WriteInt_BE compressionType
'RLE requires special handling
If (compressionType = PSD_COMPRESSION_PACKBITS) Then
'Generating RLE data is convoluted and obnoxious, so let's just reuse a standard layer object to do it!
Dim tmpPSDLayer As pdPSDLayer
Set tmpPSDLayer = New pdPSDLayer
tmpPSDLayer.PrepChannelsForWrite tmpDIB, compressionType
'The PSD layer object can also write out the channel data for us - how nice!
tmpPSDLayer.WriteSpecialMergedChannelData cStream, compressionType, writePSB, alphaMatters
'The only other supported compression type at present is raw bytes (no compression).
Else
'We simply need to write all data to file in planar format (e.g. RRRGGGBBBAAA instead of RGBARGBARGBA...)
Dim x As Long, y As Long
Dim lWidth As Long, lHeight As Long, xLoopSrc As Long, yLoopSrc As Long
Dim dstOffset As Long
lWidth = tmpDIB.GetDIBWidth
lHeight = tmpDIB.GetDIBHeight
xLoopSrc = lWidth - 1
yLoopSrc = lHeight - 1
'Pre-cache each plane individually before writing, to improve performance.
Dim chSize As Long
chSize = lWidth * lHeight
Dim planarBytes() As Byte
If alphaMatters Then ReDim planarBytes(0 To chSize * 4 - 1) As Byte Else ReDim planarBytes(0 To chSize * 3 - 1) As Byte
Dim tmpBytes() As Byte, tmpSA As SafeArray1D
Dim scanStart As Long, scanWidth As Long
tmpDIB.WrapArrayAroundScanline tmpBytes, tmpSA, 0
scanStart = tmpSA.pvData
scanWidth = tmpDIB.GetDIBStride
For y = 0 To yLoopSrc
tmpSA.pvData = scanStart + scanWidth * y
For x = 0 To xLoopSrc
dstOffset = y * lWidth + x
'Destination channels are in RGBA order, not BGRA order
planarBytes(dstOffset) = tmpBytes(x * 4 + 2)
planarBytes(chSize + dstOffset) = tmpBytes(x * 4 + 1)
planarBytes(chSize * 2 + dstOffset) = tmpBytes(x * 4)
If alphaMatters Then planarBytes(chSize * 3 + dstOffset) = tmpBytes(x * 4 + 3)
Next x
Next y
tmpDIB.UnwrapArrayFromDIB tmpBytes
'Write the planar data to file
cStream.WriteByteArray planarBytes
End If
'If alpha does *not* matter, we want to do something kind of hacky - we want to return to very near
' the start of the file, and embed a "3" instead of "4" for the number of channels in the image.
If (Not alphaMatters) Then
Dim curStreamPosition As Long
curStreamPosition = cStream.GetPosition()
'This is effectively a magic number: 4 bytes ASCII signature + 2 bytes version no. + 6 reserved bytes = 12
cStream.SetPosition 12, FILE_BEGIN
cStream.WriteInt_BE 3
cStream.SetPosition curStreamPosition, FILE_BEGIN
End If
End Function
Private Function ExportStep3_WriteLayerAndMaskInformation(ByRef cStream As pdStream, ByRef srcImage As pdImage, Optional ByVal compressionType As Long = 0, Optional ByVal writePSB As Boolean = False) As PD_PSDResult
'As with other segments in a PSD file, the first marker in this segment is a "net length" marker.
' We can't possibly predict this value in advance, so just write a dummy value and we'll overwrite
' it at the end of this function with a correct value.
Dim startPosition As Long
startPosition = cStream.GetPosition()
cStream.WriteLong_BE 0
'The layer and mask info section is broken into several sub-sections:
' 1) Layer info
' 2) Global mask info
' 3) Misc tagged blocks
'Each of these sections contains multiple sub-sections of their own.
ExportStep3_WriteLayerAndMaskInformation = ExportStep3a_WriteLayerInfo(cStream, srcImage, compressionType, writePSB)
'With all layer and channel data written, the last segment we need to write is global layer mask info.
' This is always 0.
cStream.WriteLong_BE 0
'No misc blocks are written in this global section (at present)
'All writes are complete, which means we can (finally) calculate the size of this segment.
Dim finalPosition As Long, segmentSize As Long
finalPosition = cStream.GetPosition()
segmentSize = (finalPosition - startPosition) - 4
'Return to the initial length parameter and write it out correctly.
cStream.SetPosition startPosition, FILE_BEGIN
cStream.WriteLong_BE segmentSize 'Do not include the length value itself in the size calculation
cStream.SetPosition finalPosition, FILE_BEGIN
End Function
Private Function ExportStep3a_WriteLayerInfo(ByRef cStream As pdStream, ByRef srcImage As pdImage, Optional ByVal compressionType As Long = 0, Optional ByVal writePSB As Boolean = False) As PD_PSDResult
'As always, we start with a (currently unknown) length marker. Unlike other segments, this one
' should actually be rounded up to a multiple of 2.
Dim startPosition As Long
startPosition = cStream.GetPosition()
cStream.WriteLong_BE 0
'Next comes layer count. When reading PSD files from Photoshop, it may use a negative layer count to describe
' special alpha packing (per the spec, "If [layer count] is a negative number, its absolute value is the number
' of layers and the first alpha channel contains the transparency data for the merged result.") We don't need
' to write this case, so we only ever write the *actual* layer count.
cStream.WriteInt_BE srcImage.GetNumOfLayers()
'Next comes a variable-length segment called "layer records". One of these records exists for each layer.
' Because all PSD layer-specific data is managed by a dedicated class, it's easier for us to offload
' layer embedding tasks to that same class. Note that we want the classes to be persistent for the duration
' of this function because each layer header must define the length of the layer's pixel data; it's easiest
' to calculate both of those simultaneously, then keep the channel data in-memory for subsequent embedding
' after all layer segments are written.
Dim tmpPSDLayers() As pdPSDLayer
ReDim tmpPSDLayers(0 To srcImage.GetNumOfLayers - 1) As pdPSDLayer
Dim i As Long
For i = 0 To srcImage.GetNumOfLayers() - 1
Set tmpPSDLayers(i) = New pdPSDLayer
tmpPSDLayers(i).WriteLayerData cStream, srcImage.GetLayerByIndex(i), compressionType, writePSB
Next i
'During the previous step, each layer generated a compressed byte stream of each channel's pixel data
' (remember: PSDs store channels as planar, not interleaved). That makes the next step - storing channel
' data - trivial, as we can just ask each layer object to dump channel data out to file.
For i = 0 To srcImage.GetNumOfLayers() - 1
tmpPSDLayers(i).WriteChannelData cStream, compressionType, writePSB
Next i
'All writes are complete, which means we can (finally) calculate the size of this segment.
Dim finalPosition As Long, segmentSize As Long
finalPosition = cStream.GetPosition()
segmentSize = (finalPosition - startPosition) - 4
'The spec says that the segment size should be a multiple of 2. Enforce this now.
If (segmentSize And 1) = 1 Then
finalPosition = finalPosition + 1
segmentSize = segmentSize + 1
cStream.WriteByte 0
End If
'Return to the initial length parameter and write it out correctly.
cStream.SetPosition startPosition, FILE_BEGIN
cStream.WriteLong_BE segmentSize 'Do not include the length value itself in the size calculation
cStream.SetPosition finalPosition, FILE_BEGIN
ExportStep3a_WriteLayerInfo = psd_Success
End Function
Private Function ExportStep2_WriteImageResources(ByRef cStream As pdStream, ByRef srcImage As pdImage, Optional ByVal useMaxCompatibility As Boolean = True, Optional ByVal writePSB As Boolean = False) As PD_PSDResult
'Before doing anything else, we need to make a note of the current stream position. The first entry
' in this segment is the TOTAL LENGTH of the image resource segment. We can't predict this value in
' advance (not easily, anyway), so we just write a dummy value for now, then return and fill in the
' "correct" value when the section is finished.
Dim startPosition As Long
startPosition = cStream.GetPosition()
cStream.WriteLong_BE 0
'Image resource blocks all use a fixed structure:
' - 4 byte signature '8BIM'
' - 2 byte unique ID (hard-coded and defined by Adobe)
' - Variable-length Pascal string w/ resource name (in practice, this always seems to be a two-byte null-string)
' - 4 byte size of resource data
' - actual resource data (even-padded according to the spec, but this does *not* appear to be practiced IRL)
'A cleaner implementation would use dedicated sub-classes for each possible resource block type. We don't do
' this because VB6 makes it impossible to cleanly organize large class collections. (Also, we don't actually
' write many image resource blocks, so this function is manageable for now.) That's why you'll see a bunch
' of ugly naked stream writes here.
'PSD images from Photoshop typically contain dozens of image resource blocks. PhotoDemon doesn't attempt to
' mimic this behavior; instead, we only write blocks that contain information relevant to the current PD session.
' (Photoshop will fill in default values for any blocks we don't supply.)
'Here are the blocks we currently write.
'First, a resolution info block (0x03ED). The PSD spec does not define this; instead, you have to track down
' Appendix A of the Photoshop API guide. (Fortunately, it's an easy segment to write, aside from the hassle
' of using fixed-point fractional values.)
Dim blockSize As Long
blockSize = 16
WriteImageResourceHeader cStream, &H3ED, blockSize
'Horizontal resolution (as fixed 16-16), resolution unit (1=ppi), and width unit (1=inches)
cStream.WriteFixed1616_BE srcImage.GetDPI()
cStream.WriteInt_BE 1
cStream.WriteInt_BE 1
'Vertical resolution is exactly the same
cStream.WriteFixed1616_BE srcImage.GetDPI()
cStream.WriteInt_BE 1
cStream.WriteInt_BE 1
'Second, an ICC profile (0x040F). At present, all images exported from PhotoDemon are hard-converted to sRGB.
' PSD is the rare format where an embedded profile would actually (most likely?) be used by target software,
' instead of being completely ignored as usual... but some internal changes would have to be made to make
' that feasible. Instead, we just generate a stock sRGB profile on-the-fly and embed it.
'
'(I've gone back and forth on the compatibility complications of writing this profile in modern v4 format.
' v4 profiles date back to 2001, but some people use *really* old software, so for now, PD forcibly generates
' a larger-but-more-compatible v2.1 sRGB profile for embedding whenever "maximum compatibility" is checked
' (as it is by default). Note that the contents of v2 vs v4 sRGB profiles are identical in how the image
' is ultimately rendered, but the v4 profile is much smaller on account of v4 descriptors that represent
' sRGB's weird gamma ramp in a compact way.)
Dim tmpProfile As pdLCMSProfile
Set tmpProfile = New pdLCMSProfile
tmpProfile.CreateSRGBProfile (Not useMaxCompatibility)
Dim profBytes() As Byte, profSize As Long
blockSize = tmpProfile.GetRawProfileBytes(profBytes)
WriteImageResourceHeader cStream, &H40F, blockSize
cStream.WriteByteArray profBytes, blockSize
'Image resource blocks must report their sizes accurately (no padding). If an image resource block size
' is ODD, however, an extra padding byte needs to be inserted after the block, so that the *next* block
' lies on an even-position boundary. (Again, this padding is *not* reported in the resource block size.)
If ((blockSize And 1) = 1) Then cStream.WriteByte 0
'Third (and last), version information (0x0421). Version information describes the program that wrote
' the PSD file. The spec doesn't mark this block as required (in fact, *no* resource blocks are required
' in a PSD file), but as with other formats, we try to follow Best Practices and take responsibility for
' the files we write.
'Size of the version number is calculated as follows:
' 4 bytes - version number (always 1)
' 1 byte - real merged data included in file (e.g. "max compatibility" used at export time)
' (variable bytes) - name of PSD writer as a "Unicode string" (4 byte len + 2 bytes * num chars)
' (variable bytes) - name of PSD reader as a "Unicode string" (4 byte len + 2 bytes * num chars)
' 4 bytes - file version (always 1)
blockSize = 4 + 1 + 4 'Fixed-size entries
blockSize = blockSize + 4 + 4 'Size descriptors for two Unicode strings
Dim writerName As String, readerName As String
writerName = "PhotoDemon"
readerName = writerName & " " & Updates.GetPhotoDemonVersion()
blockSize = blockSize + LenB(writerName) + LenB(readerName) 'Add string sizes to calculation
WriteImageResourceHeader cStream, &H421, blockSize
cStream.WriteLong_BE 1
If useMaxCompatibility Then cStream.WriteByte 1 Else cStream.WriteByte 0
cStream.WriteLong_BE Len(writerName)
cStream.WriteString_UnicodeBE writerName
cStream.WriteLong_BE Len(readerName)
cStream.WriteString_UnicodeBE readerName
cStream.WriteLong_BE 1
'See above note about image resource block padding
If ((blockSize And 1) = 1) Then cStream.WriteByte 0
'All image resource blocks have been written successfully!
'Remember the beginning of this function? We now need to return to the start of this segment and write out
' a *correct* "length of segment" marker.
Dim finalPosition As Long, fullSizeOfSegment As Long
finalPosition = cStream.GetPosition()
fullSizeOfSegment = (finalPosition - startPosition) - 4 'Subtract 4 because the length marker itself is not included in the size calculation
cStream.SetPosition startPosition, FILE_BEGIN
cStream.WriteLong_BE fullSizeOfSegment
cStream.SetPosition finalPosition, FILE_BEGIN
ExportStep2_WriteImageResources = psd_Success
End Function
Private Sub WriteImageResourceHeader(ByRef cStream As pdStream, ByVal resID As Integer, ByVal resDataSize As Long)
'Always start with the hard-coded signature
Const IMAGE_RESOURCE_SIGNATURE As String = "8BIM"
cStream.WriteString_ASCII IMAGE_RESOURCE_SIGNATURE
'Next, the resource ID
cStream.WriteIntU_BE resID
'Next, a null Pascal string as the "resource name"
cStream.WriteByte 0 '0 length
cStream.WriteByte 0 'Extra byte for padding
'Next, size of the resource data
cStream.WriteLong_BE resDataSize
'Writing of the actual data is left to the caller
End Sub
Private Function ExportStep1_WriteHeaderAndColorTable(ByRef cStream As pdStream, ByRef srcImage As pdImage, Optional ByVal useMaxCompatibility As Boolean = True, Optional ByVal writePSB As Boolean = False) As PD_PSDResult
' As noted previously, VB6 struct alignment issues prevent us from easily writing out structs "as-is";
' instead, we write out members one-at-a-time.
'Magic number
cStream.WriteString_ASCII "8BPS"
'Version: 1 for PSD, 2 for PSB
cStream.WriteInt_BE 1
'6 reserved bytes; must be 0
cStream.WritePadding 6
'Number of channels in the image, including alpha. This is a little convoluted to write,
' because we only want to embed alpha data in the base layer if it's actually relevant
' (e.g. if the merged image is *not* fully opaque). Because generating an extra merged copy
' of the full image is expensive, we only want to do it once, at the end of this function -
' so for now, just assume 4-channel RGBA and we will revisit this value later if we determine
' that the image's alpha data is pointless.
cStream.WriteInt_BE 4
'Height and width of the image, in pixels
cStream.WriteLong_BE srcImage.Height
cStream.WriteLong_BE srcImage.Width
'Number of bits per channel; PD always writes 8bx4 channels at present
cStream.WriteInt_BE 8
'Color mode; PD always writes RGB images at present.
cStream.WriteInt_BE cm_RGB
'While here, let's also write the color mode data segment. In indexed images, this segment stores palette data.
' It is unused by PhotoDemon exports so we only need to populate the first field - segment length, which is 0.
cStream.WriteLong_BE 0
ExportStep1_WriteHeaderAndColorTable = psd_Success
End Function
'Only valid after LoadPSD has been called
Friend Sub GetColorTableData(ByRef dstColors() As RGBQuad, ByRef dstColorCount As Long, ByRef dstTransparentIndex As Long)
ReDim dstColors(0 To 255) As RGBQuad
If (m_ColorTableCount > 0) Then
CopyMemoryStrict VarPtr(dstColors(0)), VarPtr(m_ColorTable(0)), 256 * 4
dstColorCount = m_ColorTableCount
dstTransparentIndex = m_TransparentIndex
Else
dstColorCount = 0
dstTransparentIndex = -1
End If
End Sub
'Only valid after LoadPSD has been called
Friend Function GetHResolution() As Single
GetHResolution = m_ResolutionInfo.riHRes
End Function
'Only valid after LoadPSD has been called
Friend Function GetVResolution() As Single
GetVResolution = m_ResolutionInfo.riVRes
End Function
'Only valid after LoadPSD has been called
Friend Function GetBytesPerPixel() As Long
Dim bytesPerChannel As Long
bytesPerChannel = (m_Header.BitsPerChannel \ 8)
'Bits per pixel is a little convoluted to calculate, as it depends on both color mode and color depth
' (and optionally, the presence of alpha).
With m_Header
If (.ColorMode = cm_Bitmap) Then
GetBytesPerPixel = 1
ElseIf (.ColorMode = cm_CMYK) Then
GetBytesPerPixel = bytesPerChannel * 4
If Me.HasAlpha() Then GetBytesPerPixel = GetBytesPerPixel + bytesPerChannel
ElseIf (.ColorMode = cm_Duotone) Then
GetBytesPerPixel = bytesPerChannel
ElseIf (.ColorMode = cm_Grayscale) Then
GetBytesPerPixel = bytesPerChannel
If Me.HasAlpha() Then GetBytesPerPixel = GetBytesPerPixel * 2
ElseIf (.ColorMode = cm_Indexed) Then
GetBytesPerPixel = 8
ElseIf (.ColorMode = cm_Lab) Then
GetBytesPerPixel = bytesPerChannel * 3
If Me.HasAlpha() Then GetBytesPerPixel = GetBytesPerPixel + bytesPerChannel
'Multichannel doesn't have a meaningful analog in PD; treat it as grayscale
ElseIf (.ColorMode = cm_Multichannel) Then
GetBytesPerPixel = bytesPerChannel
If Me.HasAlpha() Then GetBytesPerPixel = GetBytesPerPixel * 2
ElseIf (.ColorMode = cm_RGB) Then
GetBytesPerPixel = bytesPerChannel * 3
If Me.HasAlpha() Then GetBytesPerPixel = GetBytesPerPixel + bytesPerChannel
Else
GetBytesPerPixel = 32
End If
End With
End Function
'Only valid after LoadPSD has been called
Friend Function GetColorMode() As PSD_ColorMode
GetColorMode = m_Header.ColorMode
End Function
'Only valid after LoadPSD has been called
Friend Function HasAlpha() As Boolean
Dim i As Long
For i = 0 To Abs(m_numOfLayers) - 1
If Not (m_Layers(i) Is Nothing) Then
If m_Layers(i).HasAlpha Then HasAlpha = True
End If
Next i
End Function
'Only valid after LoadPSD has been called
Friend Function HasICCProfile() As Boolean
HasICCProfile = Not (m_Profile Is Nothing)
End Function
Friend Function GetICCProfile() As pdICCProfile
Set GetICCProfile = m_Profile
End Function
'Only valid after LoadPSD has been called
Friend Function IsGrayscaleColorMode() As Boolean
IsGrayscaleColorMode = (m_Header.ColorMode = cm_Grayscale) Or (m_Header.ColorMode = cm_Multichannel)
End Function
Private Function Step5_AssemblePDImage(ByRef srcFile As String, ByRef dstImage As pdImage) As PD_PSDResult
On Error GoTo InternalVBError
Step5_AssemblePDImage = psd_Success
'Failsafe check
If Strings.StringsNotEqual(m_SourceFilename, srcFile, False) Then
InternalError "Step5_AssemblePDImage", "filename has changed since original validation!"
Step5_AssemblePDImage = psd_Failure
Exit Function
End If
'Set basic image attributes
dstImage.Width = m_Header.ImageWidthPx
dstImage.Height = m_Header.ImageHeightPx
'Use retrieved DPI, if available, but if not, note that PSDs default to 72 ppi
Dim hDPI As Single, vDPI As Single
hDPI = Me.GetHResolution()
vDPI = Me.GetVResolution()
If (hDPI <= 0!) Then hDPI = 72!
If (vDPI <= 0!) Then vDPI = 72!
dstImage.SetDPI hDPI, vDPI
Dim tmpLayer As pdLayer, numUsableLayers As Long, newLayerID As Long
numUsableLayers = 0
'Now we need to iterate through layers and convert their data from PSD format to PD format
Dim i As Long
For i = 0 To Abs(m_numOfLayers) - 1
If m_Layers(i).DoesLayerHaveUsableData() Then
'Multichannel images are handled differently; each channel is displayed in its own layer
If (m_Header.ColorMode = cm_Multichannel) Then
Dim j As Long
For j = 0 To m_Layers(i).GetLayerCount - 1
'Prep a new layer object and initialize it with the image bits we've retrieved
newLayerID = dstImage.CreateBlankLayer()
Set tmpLayer = dstImage.GetLayerByID(newLayerID)
Dim newLayerName As String
newLayerName = g_Language.TranslateMessage("%1 (Channel %2)", m_Layers(i).GetLayerName(), m_Layers(i).GetMultiChannelLayerID(j))
tmpLayer.InitializeNewLayer PDL_IMAGE, newLayerName, m_Layers(i).GetMultiChannelLayerDIB(j)
'Fill in any remaining layer properties
With m_Layers(i)
'Hardcode "darken" blend mode so that the resulting layers composite together
' into a rough estimation of the original result
tmpLayer.SetLayerBlendMode BL_DARKEN
tmpLayer.SetLayerOpacity .GetLayerOpacity()
tmpLayer.SetLayerOffsetX .GetLayerOffsetX()
tmpLayer.SetLayerOffsetY .GetLayerOffsetY()
tmpLayer.SetLayerVisibility .GetLayerVisibility()
End With
Next j
numUsableLayers = numUsableLayers + 1
'All other color modes are handled normally, with a 1:1 correspondence between
' PSD layers and PhotoDemon layers
Else
'Prep a new layer object and initialize it with the image bits we've retrieved
newLayerID = dstImage.CreateBlankLayer()
Set tmpLayer = dstImage.GetLayerByID(newLayerID)
tmpLayer.InitializeNewLayer PDL_IMAGE, m_Layers(i).GetLayerName(), m_Layers(i).GetLayerDIB()
'Fill in any remaining layer properties
With m_Layers(i)
tmpLayer.SetLayerBlendMode .GetLayerBlendMode()
tmpLayer.SetLayerOpacity .GetLayerOpacity()
tmpLayer.SetLayerOffsetX .GetLayerOffsetX()
tmpLayer.SetLayerOffsetY .GetLayerOffsetY()
tmpLayer.SetLayerVisibility .GetLayerVisibility()
End With
numUsableLayers = numUsableLayers + 1
End If
End If
Next i
'Make sure we were able to generate at least one usable layer.
If (numUsableLayers <= 0) Or (dstImage.GetNumOfLayers <= 0) Then
m_Warnings.AddString "unable to create any usable layers. Abandoning load."
Step5_AssemblePDImage = psd_Failure
Exit Function
End If
'Look for the "clipping" flag on any loaded layers. If it is set, we can mimic the clipping results by
' merging the alpha channel of any clipped layers with the alpha channel of the lowest non-background
' layer in the image (I think? Photoshop's strategy may be more complicated than this, but I don't
' have enough images available to test it well.)
' TODO!
Exit Function
InternalVBError:
InternalError "Step5_AssemblePDImage", "internal VB error #" & Err.Number & ": " & Err.Description
m_Warnings.AddString "Internal error in step 5, #" & Err.Number & ": " & Err.Description
Step5_AssemblePDImage = psd_Failure
End Function
Private Function Step4B_SingleLayerImage() As PD_PSDResult
'If a PSD only contains one layer, the layer's data will be saved at the end of the file,
' in the "image data" section. Step4_GatherLayersAndMasks() will defer to us in this case,
' so we can manually load the remaining layer data.
m_numOfLayers = 1
ReDim m_Layers(0) As pdPSDLayer
Set m_Layers(0) = New pdPSDLayer
Dim addLayerInfo As pdPSDLayerInfo
Set addLayerInfo = New pdPSDLayerInfo
'With the pointer now correctly aligned, we can proceed with gathering pixel data
Step4B_SingleLayerImage = m_Layers(0).NotifySingleLayerImage(m_Stream, m_Warnings, m_PSDisPSB, m_Header.NumChannels, m_Header.ImageWidthPx, m_Header.ImageHeightPx, m_Header.BitsPerChannel, m_Header.ColorMode, addLayerInfo)
'If image data was parsed successfully, proceed with decoding
If (Step4B_SingleLayerImage < psd_Failure) Then
If (m_Layers(0).DecodeChannels(m_Warnings, m_PSDisPSB, m_Header.BitsPerChannel, m_Header.ColorMode, Me) < psd_Failure) Then
Step4B_SingleLayerImage = m_Layers(0).ConstructImage(m_Stream, m_Warnings, m_PSDisPSB, m_Header.BitsPerChannel, m_Header.ColorMode, m_Profile, Me)
Else
InternalError "Step4B_SingleLayerImage", "pdPSDLayer.DecodeChannels() failed catastrophically"
Step4B_SingleLayerImage = psd_Failure
End If
End If
End Function
Private Function Step4_GatherLayersAndMasks(ByRef srcFile As String) As PD_PSDResult
On Error GoTo InternalVBError
Step4_GatherLayersAndMasks = psd_Success
'Failsafe check
If Strings.StringsNotEqual(m_SourceFilename, srcFile, False) Then
InternalError "Step4_GatherLayersAndMasks", "filename has changed since original validation!"
Step4_GatherLayersAndMasks = psd_Failure
Exit Function
End If
'The layer and mask section of a PSD is extremely complicated. Almost all records are variable-length,
' and values within records can also be variable-length. Individual bits often need to be read to know
' how many more bytes to read. It's all very, very ugly.
'For now, our primary goal is retrieving layer channel data. Other (optional) attributes can be extracted
' in the future.
'First up is the length of the entire layer/mask section. This is 4-bytes in PSDs and 8-bytes in PSBs.
' (While we handle both cases, note that PD is unlikely to work with PSBs on account of being 32-bit.)
Dim lenOfSection As Long, finalPointerPosition As Long
lenOfSection = m_Stream.ReadLong_BE()
If m_PSDisPSB Then lenOfSection = m_Stream.ReadLong_BE() 'TODO: fix PSB approach
finalPointerPosition = m_Stream.GetPosition() + lenOfSection
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "Length of layer and mask section (offset " & CStr(m_Stream.GetPosition - 4) & "): " & lenOfSection
'If a PSD only contains one layer, it can be written at the end of the file (in the
' "image data" segment), bypassing this section completely. To cover this special case,
' we hand off control to a separate function (as the data layout differs in subtle,
' obnoxious ways).
If (lenOfSection <= 0) Then
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "Single-layer PSD found. Retrieving layer data from image segment instead..."
Step4_GatherLayersAndMasks = Step4B_SingleLayerImage()
Exit Function
End If
'The remainder of the chunk is comprised of three subsections:
' 1) Layer info
' 2) Global layer mask info
' 3) Tagged blocks with miscellaneous layer/mask data (PS4 or later, only)
'The layer info section has its own length marker, and per the spec, it is
' "rounded up to a multiple of 2".
Dim lenOfLayerInfoSection As Long, finalLayerInfoPosition As Long
lenOfLayerInfoSection = m_Stream.ReadLong_BE()
If m_PSDisPSB Then lenOfLayerInfoSection = m_Stream.ReadLong_BE() 'TODO: fix PSB approach
finalLayerInfoPosition = m_Stream.GetPosition() + finalLayerInfoPosition
'The layer info section *can* have zero-length; this is common on 16-bit images, for example,
' as the actual layer data is stored in a separate chunk for backward-compatibility reasons.
' (Also, see the psd-tools collection of test images - they cover this case.)
If (lenOfLayerInfoSection = 0) Then
'Layer info section is null. We now have one of two possibilities:
' 1) This is a single-layer image, and PhotoShop has placed the background layer data in the
' composite image chunk at the end of the file. We can grab that, no problem.
' 2) This is a high bit-depth image, and PhotoShop has placed the actual layer data inside a
' specialized "Lr16" or "Lr32" additional info block (presumably for backward-compatibility).
'
' We can distinguish between these two states using the length of the layer chunk.
Dim hpdChunkFound As Boolean
hpdChunkFound = False
If (m_Stream.GetPosition < finalPointerPosition) Then
'Even though there are no layers, there is global mask data and/or additional
' "global" layer info blocks (for lack of a better term; the spec is nebulous on
' what these blocks may even hold).
'Global mask data gets checked first. (We don't use this data in PD, so we just
' read it using a temp layer.)
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "Checking for global mask data..."
Dim tmpLayer As pdPSDLayer
Set tmpLayer = New pdPSDLayer
Step4_GatherLayersAndMasks = tmpLayer.ParseGlobalLayerMaskInfo(m_Stream, m_Warnings, m_PSDisPSB)
'Finally, if the stream pointer is *still* not at the end of the section, it means optional
' additional tagged blocks are present. Newer versions of Photoshop may write critical
' image data here (e.g. pixel data for 16/32-bit channels) so it's crucial to retrieve
' these segments.
Dim addLayerInfo As pdPSDLayerInfo
Set addLayerInfo = New pdPSDLayerInfo
If (m_Stream.GetPosition < finalPointerPosition) Then
'Parse and acquire all tagged blocks, then reset the stream pointer to a
' known-aligned position.
addLayerInfo.ParseAdditionalLayerInfo m_Stream, m_Warnings, m_PSDisPSB, finalPointerPosition, True
m_Stream.SetPosition finalPointerPosition, FILE_BEGIN
End If
'If we found a high bit-depth segment, we want to continue parsing the file, but using that
' high bit-depth segment as if it were the actual file contents.
If addLayerInfo.DoesKeyExist("Lr16") Or addLayerInfo.DoesKeyExist("Lr32") Then
hpdChunkFound = True
'Close our original stream; it no longer serves any purpose
Set m_Stream = New pdStream
'Instead, wrap the m_Stream object around the high bit-depth block
If addLayerInfo.DoesKeyExist("Lr16") Then
Set m_Stream = addLayerInfo.GetStreamForKey("Lr16")
Else
Set m_Stream = addLayerInfo.GetStreamForKey("Lr32")
End If
'Reset any/all pointer trackers to match the new stream length and position.
lenOfLayerInfoSection = m_Stream.GetStreamSize()
End If
End If
'If we didn't find a high bit-depth segment, this is just a plain single-layer image.
' The single background layer's contents live in the composite image segment.
If (Not hpdChunkFound) Then
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "Single-layer PSD found. Activating alternate parse strategy..."
Step4_GatherLayersAndMasks = Step4B_SingleLayerImage()
Exit Function
End If
End If
'By this point, if we still have a non-zero layer info segment, we can parse it normally,
' regardless of where the data actually resides. (Previous steps may have pointed the
' stream at an alternate segment of the PSD file without us knowing; that's by design.)
If (lenOfLayerInfoSection > 0) Then
Dim i As Long
'Next comes a two-byte "layer count", which is actually a signed integer. Per the spec:
' "If it is a negative number, its absolute value is the number of layers and the first
' alpha channel contains the transparency data for the merged result."
Dim numOfLayers As Integer
numOfLayers = m_Stream.ReadInt_BE()
'Again, not sure if the layer count can be zero-length, but just in case...
If (numOfLayers <> 0) Then
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction Abs(numOfLayers) & " layers found. Parsing layer data now..."
'The "layer records" section comes next. Layer records describe everything needed to perfectly
' re-create a Photoshop layer. As you can imagine, these records are massive, and most of the
' information is useful only to Adobe.
'Because these records are so complex, they are parsed by a child class, and that class stores
' whatever relevant information we are able to extract.
'Start by initializing a collection of layer child objects
m_numOfLayers = numOfLayers
ReDim m_Layers(0 To Abs(m_numOfLayers) - 1) As pdPSDLayer
'We now rely on the child class to handle further processing. Iterate through each layer
' in turn and hand it off to a new child class instance.
For i = 0 To Abs(m_numOfLayers) - 1
Set m_Layers(i) = New pdPSDLayer
If (Not m_Layers(i).ParseLayer(m_Stream, m_Warnings, m_PSDisPSB) < psd_Failure) Then
InternalError "Step4_GatherLayersAndMasks", "pdPSDLayer.ParseLayer() failed catastrophically"
Step4_GatherLayersAndMasks = psd_Failure
Exit Function
End If
Next i
'/end null layer count check
End If
'With each layer loaded, we can now proceed with loading channel data (eek). Because Adobe stores
' channel data in planar order (not interleaved, e.g. RRRGGGBBB instead of RGBRGBRGB) this step
' consumes a lot of memory, as we can't easily stream in chunks of the data at a time - instead,
' we have to allocate the full memory and populate it as-we-go.
For i = 0 To Abs(m_numOfLayers) - 1
If (m_Layers(i).LoadChannels(m_Stream, m_Warnings, m_PSDisPSB, m_Header.BitsPerChannel, m_Header.ColorMode) >= psd_Failure) Then
InternalError "Step4_GatherLayersAndMasks", "pdPSDLayer.LoadChannels() failed catastrophically"
Step4_GatherLayersAndMasks = psd_Failure
Exit Function
End If
Next i
'If global mask data is present, parse it now.
If (Step4_GatherLayersAndMasks < psd_Failure) Then Step4_GatherLayersAndMasks = m_Layers(0).ParseGlobalLayerMaskInfo(m_Stream, m_Warnings, m_PSDisPSB)
'Finally, an additional set of additional layer information (that's not confusing at all)
' may follow the global mask. This section is entirely optional, and the spec is fuzzy about
' what these chunks may contain. We don't have a use for it in PD at present, so we just
' skip this segment pending further investigation.
If (Step4_GatherLayersAndMasks < psd_Failure) Then
'TODO?
End If
'With all channels loaded, we can now ask each layer to decode the channel data into a
' format we can actually interpret. The amount of work involved varies by channel
' type (e.g. layer masks differ from color channels) and compression type.
For i = 0 To Abs(m_numOfLayers) - 1
'To avoid wasting time, skip layers with null sizes
If (m_Layers(i).GetLayerWidth <= 0) Or (m_Layers(i).GetLayerHeight <= 0) Then GoTo SkipLayer
If (m_Layers(i).DecodeChannels(m_Warnings, m_PSDisPSB, m_Header.BitsPerChannel, m_Header.ColorMode, Me) < psd_Failure) Then
'If the channel decoded successfully, convert it from a bare byte/int/float stream
' into usable pixel data. This comprehensive stage translates channel data to
' 8-bpc, converts the resulting channel collection from planar to 32-bpp interleaved
' RGBA, and color-manages the results. The end result is a PD-compatible image buffer
' that can be directly associated with a pdLayer object.
If (Not m_Layers(i).ConstructImage(m_Stream, m_Warnings, m_PSDisPSB, m_Header.BitsPerChannel, m_Header.ColorMode, m_Profile, Me) < psd_Failure) Then
InternalError "Step4_GatherLayersAndMasks", "pdPSDLayer.ConstructImage() failed catastrophically"
Step4_GatherLayersAndMasks = psd_Failure
Exit Function
End If
Else
InternalError "Step4_GatherLayersAndMasks", "pdPSDLayer.DecodeChannels() failed catastrophically"
Step4_GatherLayersAndMasks = psd_Failure
Exit Function
End If
SkipLayer:
Next i
'Layer info section is null-length; layer data has already been located using an alternate strategy
End If
'At the end of this step, we are finished with the source stream object. Free it to conserve resources.
m_Stream.StopStream True
Exit Function
InternalVBError:
InternalError "Step4_GatherLayersAndMasks", "internal VB error #" & Err.Number & ": " & Err.Description
If m_Stream.IsOpen Then m_Stream.StopStream True
m_Warnings.AddString "Internal error in step 4, #" & Err.Number & ": " & Err.Description
Step4_GatherLayersAndMasks = psd_Failure
End Function
'From the spec: "Image resource blocks are the basic building unit of several file formats, including Photoshop's
' native file format, JPEG, and TIFF. Image resources are used to store non-pixel data associated with images,
' such as pen tool paths. They are referred to as resource blocks because they hold data that was stored in the
' Macintosh's resource fork in early versions of Photoshop.
Private Function Step3_GatherImageResources(ByRef srcFile As String, ByRef dstImage As pdImage) As PD_PSDResult
On Error GoTo InternalVBError
Step3_GatherImageResources = psd_Success
'Failsafe check
If Strings.StringsNotEqual(m_SourceFilename, srcFile, False) Then
InternalError "Step3_GatherImageResources", "filename has changed since original validation!"
Step3_GatherImageResources = psd_Failure
Exit Function
End If
'Remember that m_Stream has already been forcibly advanced past the file header (step 1)
' and color mode data (step 2). It now points at the image resources section.
'As before, the first marker in this section is the length of the ENTIRE section. As a failsafe
' against parse errors, we want to make a note of the segment end pointer; after iterating through
' all resource blocks, we will double-check this value against wherever the pointer naturally
' ended up.
Dim resSectionLength As Long
resSectionLength = m_Stream.ReadLong_BE()
m_NumImageResources = 0
If (resSectionLength > 0) Then
'Calculate a final position for this segment; we'll continue iterating blocks until we hit this
Dim finalPosition As Long
finalPosition = m_Stream.GetPosition() + resSectionLength
'Initialize our resources collection
ReDim m_ImageResources(0 To 3) As PSD_ImageResource
Dim resNameLength As Byte, resSize As Long
'In the future, we will likely want to separate and store the various resource blocks we encounter.
' Ideally, these blocks could even be preserved if a PSD is saved back out to file during a session.
' For this first prototype, however, we simply want to iterate all blocks and ensure that our
' pointer math works out correctly.
Do
Const IMAGE_RESOURCE_ID As String = "8BIM"
'Blocks *must* start with a unique '8BIM' identifier
If (m_Stream.ReadString_ASCII(4) = IMAGE_RESOURCE_ID) Then
'Prep storage
If (m_NumImageResources > UBound(m_ImageResources)) Then ReDim Preserve m_ImageResources(0 To m_NumImageResources * 2 - 1) As PSD_ImageResource
'Resource ID is a Photoshop-specific identifier. There are 100+ possible values here;
' we do not currently attempt to validate these.
m_ImageResources(m_NumImageResources).irID = m_Stream.ReadInt_BE()
'The ID is followed by a Pascal ShortString. This is a one-byte length value, followed by a
' string of chars (current system codepage) of length 0-255. Adobe forcibly pads these to be
' a length with a multiple of two, *including* the length bit (e.g. per the spec, "a null name
' consists of two bytes of zero"). In practice, these seem to always be null-strings.
resNameLength = m_Stream.ReadByte()
If (resNameLength = 0) Then
m_Stream.SetPosition 1, FILE_CURRENT 'Forcibly advance the pointer by 1 more byte
Else
'Retrieve the string, and advance by an additional byte if the string length is even.
m_ImageResources(m_NumImageResources).irName = Strings.TrimNull(m_Stream.ReadString_ASCII(resNameLength))
If ((resNameLength And 1) = 0) Then m_Stream.SetPosition 1, FILE_CURRENT
End If
'Next, read the length of the resource data. Again, note that this is padded to make the
' size even, if the resource data itself is *not* even.
resSize = m_Stream.ReadLong_BE()
m_ImageResources(m_NumImageResources).irDataLength = resSize
If PSD_DEBUG_VERBOSE Then
With m_ImageResources(m_NumImageResources)
PDDebug.LogAction "Image resource: 0x" & Hex$(.irID) & ", " & .irDataLength & " bytes"
End With
End If
'Before touching the actual resource data, calculate a final pointer position.
' This is important as...
' 1) we may not actually retrieve resource data because it's enormous and useless to us, or...
' 2) we may retrieve only a portion of the data, and...
' 3) resource data is padded to even numbers, so the useful size of the data may
' not be the amount we actually need to move the pointer.
'
'By calculating a final position in advance, we can forcibly set the stream pointer to
' this value, regardless of what we do with the actual resource data.
Dim finalResPosition As Long
finalResPosition = m_Stream.GetPosition() + resSize
If ((resSize And 1) = 1) Then finalResPosition = finalResPosition + 1
'Retrieve the resource
m_Stream.ReadBytes m_ImageResources(m_NumImageResources).irDataBytes, resSize, True
'Realign the pointer to match the previously calculated "end-of-resource" position.
m_Stream.SetPosition finalResPosition, FILE_BEGIN
m_NumImageResources = m_NumImageResources + 1
Else
m_Warnings.AddString "Image resource block starts with invalid identifier!"
End If
Loop While (m_Stream.GetPosition() < finalPosition)
'In case image resource blocks have added padding, forcibly set the stream position
' to our calculated final value.
m_Stream.SetPosition finalPosition, FILE_BEGIN
'Iterate the completed resource collection, looking for resources useful to PD
If (m_NumImageResources > 0) Then
'Temporary stream objects are useful for iterating complex resource data streams
Dim tmpStream As pdStream
Dim i As Long
For i = 0 To m_NumImageResources - 1
With m_ImageResources(i)
Select Case .irID
'ICC profiles are critical, especially if the source is CMYK
Case rid_IccProfile
If (.irDataLength > 0) Then
Set m_Profile = New pdICCProfile
m_Profile.LoadICCFromPtr .irDataLength, VarPtr(.irDataBytes(0))
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "ICC profile detected (" & CStr(.irDataLength) & " bytes)"
'Add the retrieved profile to PD's central cache, and tag the destination image
' to note that the image is color-managed
Dim colorProfileHash As String
colorProfileHash = ColorManagement.AddProfileToCache(m_Profile)
dstImage.SetColorProfile_Original colorProfileHash
End If
'Resolution info must be preserved
Case rid_ResolutionInfo
If (.irDataLength > 0) Then
Set tmpStream = New pdStream
tmpStream.StartStream PD_SM_ExternalPtrBacked, PD_SA_ReadOnly, , .irDataLength, VarPtr(.irDataBytes(0))
'Resolutions are stored as PPI in 32-bit fixed-point, while all other indicators
' are ushorts.
m_ResolutionInfo.riHRes = tmpStream.ReadFixed1616_BE()
m_ResolutionInfo.riHResUnit = tmpStream.ReadInt_BE()
m_ResolutionInfo.riWidthUnit = tmpStream.ReadInt_BE()
m_ResolutionInfo.riVRes = tmpStream.ReadFixed1616_BE()
m_ResolutionInfo.riVResUnit = tmpStream.ReadInt_BE()
m_ResolutionInfo.riHeightUnit = tmpStream.ReadInt_BE()
Set tmpStream = Nothing
End If
'In indexed images, we are interested in both the indexed table color count
' and transparency index, if any
Case rid_IndexedColorTableCount
If (.irDataLength > 0) Then
Set tmpStream = New pdStream
tmpStream.StartStream PD_SM_ExternalPtrBacked, PD_SA_ReadOnly, , .irDataLength, VarPtr(.irDataBytes(0))
m_ColorTableCount = tmpStream.ReadInt_BE()
Set tmpStream = Nothing
End If
Case rid_TransparentIndex
If (.irDataLength > 0) Then
Set tmpStream = New pdStream
tmpStream.StartStream PD_SM_ExternalPtrBacked, PD_SA_ReadOnly, , .irDataLength, VarPtr(.irDataBytes(0))
m_TransparentIndex = tmpStream.ReadInt_BE()
Set tmpStream = Nothing
End If
'At import time, "Version Info" is mostly a curiosity (it tells us what program wrote the PSD),
' but because we are a well-behaved engine, we also need to *write* this data at save time.
' PD always imports anything it attempts to write so we can verify correct round-trip behavior.
Case rid_VersionInfo
If (.irDataLength > 0) Then
Set tmpStream = New pdStream
tmpStream.StartStream PD_SM_ExternalPtrBacked, PD_SA_ReadOnly, , .irDataLength, VarPtr(.irDataBytes(0))
Dim versionNumber As Long
versionNumber = tmpStream.ReadLong_BE()
Dim hasRealMergedData As Boolean
hasRealMergedData = (tmpStream.ReadByte() <> 0)
Dim writerName As String, readerName As String
resNameLength = tmpStream.ReadLong_BE()
writerName = tmpStream.ReadString_Unicode_BE(resNameLength)
resNameLength = tmpStream.ReadLong_BE()
readerName = tmpStream.ReadString_Unicode_BE(resNameLength)
Dim fileVersion As Long
fileVersion = tmpStream.ReadLong_BE()
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "PSD version info is: " & versionNumber & ", " & hasRealMergedData & ", " & fileVersion & ", " & writerName & ", " & readerName
End If
End Select
End With
Next i
End If
'I don't believe files coming from PD will ever have a zero-length resource segment, but 3rd-party implementations
' may not use this section at all. In that case, the stream pointer will already be pointing at the next segment.
Else
Step3_GatherImageResources = psd_Success
End If
Exit Function
InternalVBError:
InternalError "Step3_GatherImageResources", "internal VB error #" & Err.Number & ": " & Err.Description
If m_Stream.IsOpen Then m_Stream.StopStream True
m_Warnings.AddString "Internal error in step 3, #" & Err.Number & ": " & Err.Description
Step3_GatherImageResources = psd_Failure
End Function
Private Function Step2_RetrieveColorModeData(ByRef srcFile As String) As PD_PSDResult
On Error GoTo InternalVBError
Step2_RetrieveColorModeData = psd_Success
'Failsafe check
If Strings.StringsNotEqual(m_SourceFilename, srcFile, False) Then
InternalError "Step2_RetrieveColorModeData", "filename has changed since original validation!"
Step2_RetrieveColorModeData = psd_Failure
Exit Function
End If
'Remember that m_Stream has already been forcibly advanced past the file header in Step 1.
'We now want to retrieve the PSD's color mode data section, if it exists. Per the spec,
' "Only indexed color and duotone have color mode data. For all other modes, this section is just
' the 4-byte length field, which is set to zero."
Dim cmLength As Long
cmLength = m_Stream.ReadLong_BE()
Dim finalPosition As Long
finalPosition = m_Stream.GetPosition() + cmLength
If (cmLength > 0) Then
'Ensure the file is indexed or duotone.
If (m_Header.ColorMode = cm_Indexed) Then
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "Color table found; extracting now..."
'Indexed mode images used a fixed-size color table. From the spec:
' "Indexed color images: length is 768; color data contains the color table for the image,
' in non-interleaved order."
'Retrieve the color table and assemble it into a usable palette.
m_ColorTableCount = 256
m_TransparentIndex = -1
ReDim m_ColorTable(0 To 255) As RGBQuad
Dim i As Long
For i = 0 To 255
m_ColorTable(i).Red = m_Stream.ReadByte()
Next i
For i = 0 To 255
m_ColorTable(i).Green = m_Stream.ReadByte()
Next i
For i = 0 To 255
m_ColorTable(i).Blue = m_Stream.ReadByte()
Next i
For i = 0 To 255
m_ColorTable(i).Alpha = 255
Next i
'The stream pointer will now be pointing at the start of the next segment.
Step2_RetrieveColorModeData = psd_Success
ElseIf (m_Header.ColorMode = cm_Duotone) Then
'Duotone data is not actually retrievable. It is a proprietary Adobe format.
' Per the spec, "Duotone images: color data contains the duotone specification (the format of
' which is not documented). Other applications that read Photoshop files can treat a duotone
' image as a gray image, and just preserve the contents of the duotone information when reading
' and writing the file."
m_Warnings.AddString "Color mode is duotone. Color table will be ignored."
Step2_RetrieveColorModeData = psd_Warning
'Other color modes should not write a color table. Advance the stream pointer accordingly,
' but also raise a warning.
Else
m_Warnings.AddString "Non-zero color mode segment exists, but image color mode isn't indexed or duotone."
Step2_RetrieveColorModeData = psd_Warning
End If
'Forcibly set the stream pointer to the correct position
m_Stream.SetPosition finalPosition, FILE_BEGIN
'If the data length is zero, the stream already points at the next section. Carry on!
Else
Step2_RetrieveColorModeData = psd_Success
End If
Exit Function
InternalVBError:
InternalError "Step2_RetrieveColorModeData", "internal VB error #" & Err.Number & ": " & Err.Description
If m_Stream.IsOpen Then m_Stream.StopStream True
m_Warnings.AddString "Internal error in step 2, #" & Err.Number & ": " & Err.Description
Step2_RetrieveColorModeData = psd_Failure
End Function
Private Function Step1_ValidateHeader(ByRef srcFile As String, Optional ByVal checkExtension As Boolean = False, Optional ByVal cacheFileIfSuccessful As Boolean = False) As PD_PSDResult
On Error GoTo InternalVBError
'If the passed path is zero, assume the caller is loading the PSD from memory.
If (LenB(srcFile) = 0) Then m_SourceFilename = PSD_LOADED_FROM_MEMORY Else m_SourceFilename = srcFile
Dim okToProceed As PD_PSDResult
okToProceed = psd_Success
'We always check the file extension. If the user has *asked* us to check it, we treat extension
' mismatches as a failure state. (Otherwise, it will only raise a warning.) This step is obviously
' skipped when a PSD is loaded directly from memory.
If (m_SourceFilename <> PSD_LOADED_FROM_MEMORY) Then
If (Strings.StringsNotEqual(Right$(m_SourceFilename, 3), "psd", True) And Strings.StringsNotEqual(Right$(m_SourceFilename, 3), "psb", True)) Then
m_Warnings.AddString "File extension doesn't match PSD"
If checkExtension Then okToProceed = psd_FileNotPSD Else okToProceed = psd_Warning
End If
End If
'If all pre-checks passed, open a stream over the source data.
If (okToProceed < psd_Failure) Then
If (m_SourceFilename = PSD_LOADED_FROM_MEMORY) Then
Set m_Stream = New pdStream
If Not m_Stream.StartStream(PD_SM_ExternalPtrBacked, PD_SA_ReadOnly, vbNullString, m_SourcePtrLen, m_SourcePtr) Then
m_Warnings.AddString "Couldn't start in-memory stream against passed pointer: " & m_SourcePtr
okToProceed = psd_Failure
End If
Else
Set m_Stream = New pdStream
If Not m_Stream.StartStream(PD_SM_FileBacked, PD_SA_ReadOnly, m_SourceFilename, , , OptimizeSequentialAccess) Then
m_Warnings.AddString "Can't read file; it may be locked or in an inaccessible location."
okToProceed = psd_Failure
End If
End If
End If
'The stream is open. Validate both the PSD's ASCII identifier and its version;
' if either fails, abandon ship.
If (okToProceed < psd_Failure) Then
Dim asciiID As String
asciiID = m_Stream.ReadString_ASCII(4)
Dim psdVersion As Integer
psdVersion = m_Stream.ReadInt_BE()
m_PSDisPSB = (psdVersion = 2)
'Validate the asciiID; this value is immutable
If (asciiID = "8BPS") Then
'Version can only be 1 (for PSD) or 2 (for PSB)
If (psdVersion = 1) Or (psdVersion = 2) Then okToProceed = psd_Success Else okToProceed = psd_Failure
If (okToProceed < psd_Failure) Then
'This appears to be a valid PSD file. If streaming from the HDD, attempt to pre-cache
' smaller files in memory to improve load time. (Obviously, we skip this step when
' loading a PSD directly from memory!)
If (m_SourceFilename <> PSD_LOADED_FROM_MEMORY) And cacheFileIfSuccessful Then
'Given the huge variance in potential PSD file sizes, I don't know of a good way to
' "predict" the gains we might get from pre-loading the file (or if this will just
' cause issues due to increased memory pressure). In lieu of something more complex,
' let's just test file size and use that as our guide - sufficiently small files
' will then "always" pre-cache successfully, while large files get some measure of
' safety against memory-related issues.
'We currently use a threshold of 50 mb. PSDs don't encode particularly efficiently,
' so we're unlikely to encounter a very small PSD that expands to huge numbers
' when expanded. (And if a file's *that* big, 50mb of RAM won't make a difference.)
Const FILE_SIZE_TOO_BIG As Long = 50000000
If (Files.FileLenW(m_SourceFilename) < FILE_SIZE_TOO_BIG) Then
Dim cachedStream As pdStream
Set cachedStream = New pdStream
'If pre-caching fails, no problem; we'll just abandon the attempt and
' continue using our original stream.
If Files.FileLoadAsPDStream(m_SourceFilename, cachedStream) Then
'Replace the master stream object and advance its pointer by six bytes
' (to bypass the fields we've already validated)
Set m_Stream = cachedStream
m_Stream.SetPosition 6&, FILE_BEGIN
If PSD_DEBUG_VERBOSE Then PDDebug.LogAction "PSD looks good; caching source file in memory for improved performance..."
End If
'/File too big to pre-cache
End If
'/PSD is being loaded from pointer, or caller explicitly asked us to *not* pre-cache
End If
'Confirm our stream is still attached to the PSD data and finish validating the header segment
If (okToProceed < psd_Failure) Then
With m_Header
.Version = psdVersion
'After the signature and version come 6 reserved bytes
m_Stream.SetPosition 6&, FILE_CURRENT
'Number of channels in the image, including alpha channels, comes next
.NumChannels = m_Stream.ReadInt_BE()
'Height/width come next (IN THAT ORDER, don't ask me why)
.ImageHeightPx = m_Stream.ReadLong_BE()
.ImageWidthPx = m_Stream.ReadLong_BE()
'Color depth
.BitsPerChannel = m_Stream.ReadInt_BE()
'Color mode
.ColorMode = m_Stream.ReadInt_BE()
'Validate all header data; if any of it doesn't conform, reject the file.
' (Validation values come from Adobe's spec, hence their arbitrary nature.)
If (.NumChannels < 1) Or (.NumChannels > 56) Then
m_Warnings.AddString "Unsupported number of channels: " & CStr(.NumChannels) & ". Load canceled."
okToProceed = psd_Failure
ElseIf (.ImageHeightPx <= 0) Or (.ImageWidthPx <= 0) Then
m_Warnings.AddString "Width and/or height is invalid (" & CStr(.ImageWidthPx) & "x" & CStr(.ImageHeightPx) & "). Load canceled."
okToProceed = psd_Failure
ElseIf (Not m_PSDisPSB) And ((.ImageHeightPx > 30000) Or (.ImageWidthPx > 30000)) Then
m_Warnings.AddString "PSD width and/or height is too large (" & CStr(.ImageWidthPx) & "x" & CStr(.ImageHeightPx) & "). Load canceled."
okToProceed = psd_Failure
ElseIf m_PSDisPSB And ((.ImageHeightPx > 300000) Or (.ImageWidthPx > 300000)) Then
m_Warnings.AddString "PSB width and/or height is too large (" & CStr(.ImageWidthPx) & "x" & CStr(.ImageHeightPx) & "). Load canceled."
okToProceed = psd_Failure
ElseIf ((.BitsPerChannel <> 1) And (.BitsPerChannel <> 8) And (.BitsPerChannel <> 16) And (.BitsPerChannel <> 32)) Then
m_Warnings.AddString "Invalid depth/bpc (" & CStr(.BitsPerChannel) & "). Load canceled."
okToProceed = psd_Failure
ElseIf ((.ColorMode < cm_Bitmap) Or (.ColorMode > cm_Lab)) Then
m_Warnings.AddString "Unknown color mode (" & CStr(.ColorMode) & "). Load canceled."
okToProceed = psd_Failure
End If
End With
End If
Else
m_Warnings.AddString "PSD header provided unknown version #" & CStr(psdVersion) & ". Load canceled."
okToProceed = psd_FileNotPSD
End If
Else
m_Warnings.AddString "PSD header failed basic validation. (This is not a PSD file.)"
okToProceed = psd_FileNotPSD
End If
End If
'Validation complete. If the file validated successfully, this function guarantees that m_Stream
' points at the first byte PAST the valid PSD/PSB header.
Step1_ValidateHeader = okToProceed
Exit Function
'Internal VB errors are always treated as catastrophic failures.
InternalVBError:
InternalError "IsFilePSD", "internal VB error #" & Err.Number & ": " & Err.Description
If (Not m_Stream Is Nothing) Then If m_Stream.IsOpen Then m_Stream.StopStream True
m_Warnings.AddString "Internal error in step 1, #" & Err.Number & ": " & Err.Description
Step1_ValidateHeader = psd_Failure
End Function
Private Function GetColorModeName(ByVal srcMode As PSD_ColorMode) As String
Select Case srcMode
Case cm_Bitmap
GetColorModeName = "Bitmap"
Case cm_Grayscale
GetColorModeName = "Grayscale"
Case cm_Indexed
GetColorModeName = "Indexed"
Case cm_RGB
GetColorModeName = "RGB"
Case cm_CMYK
GetColorModeName = "CMYK"
Case cm_Multichannel
GetColorModeName = "Multichannel"
Case cm_Duotone
GetColorModeName = "Duotone"
Case cm_Lab
GetColorModeName = "Lab"
End Select
End Function
Friend Sub Reset()
Set m_Profile = Nothing
Set m_Warnings = New pdStringStack
End Sub
Private Sub Class_Initialize()
Set m_Stream = New pdStream
Me.Reset
End Sub
Private Sub Class_Terminate()
If (Not m_Stream Is Nothing) Then
If m_Stream.IsOpen() Then m_Stream.StopStream True
End If
End Sub
Private Sub InternalError(ByRef funcName As String, ByRef errDescription As String, Optional ByVal writeDebugLog As Boolean = True)
If UserPrefs.GenerateDebugLogs Then
If writeDebugLog Then PDDebug.LogAction "pdPSD." & funcName & "() reported an error on file """ & m_SourceFilename & """: " & errDescription
Else
Debug.Print "pdPSD." & funcName & "() reported an error on file """ & m_SourceFilename & """: " & errDescription
End If
End Sub
'Want data on warnings? Use these helper functions.
Friend Function Warnings_GetCount() As Long
Warnings_GetCount = m_Warnings.GetNumOfStrings()
End Function
Friend Sub Warnings_CopyList(ByRef dstStack As pdStringStack)
Set dstStack = m_Warnings
End Sub
Friend Sub Warnings_DumpToDebugger()
If (m_Warnings.GetNumOfStrings() > 0) Then
Dim i As Long
For i = 0 To m_Warnings.GetNumOfStrings() - 1
PDDebug.LogAction "(" & CStr(i + 1) & ") WARNING: pdPSD reported: " & m_Warnings.GetString(i)
Next i
End If
End Sub
You can’t perform that action at this time.
You signed in with another tab or window. Reload to refresh your session. You signed out in another tab or window. Reload to refresh your session.