home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD1257912112000.psc / modFilePSD.bas < prev    next >
Encoding:
BASIC Source File  |  2000-05-14  |  7.7 KB  |  194 lines
  1. Attribute VB_Name = "modFilePSD"
  2. Type PSDInfo
  3.   Pixels() As Byte
  4.   BitsPerChannel As Integer
  5.   ColorData(0 To 767) As Byte    'For Indexed or DuoTone only
  6.   Mode As Integer
  7.   Width As Long
  8.   Height As Long
  9.   ChannelCount As Integer
  10.   Compression As Integer
  11. End Type
  12. Dim ImageInfo As PSDInfo
  13. Dim b3 As Byte, b2 As Byte, b1 As Byte, b0 As Byte
  14. Dim FilePointer As Long
  15.  
  16. Private Function Read32(filenumber) As Long
  17.     Get #filenumber, FilePointer, b3
  18.     FilePointer = FilePointer + 1
  19.     Get #filenumber, FilePointer, b2
  20.     FilePointer = FilePointer + 1
  21.     Get #filenumber, FilePointer, b1
  22.     FilePointer = FilePointer + 1
  23.     Get #filenumber, FilePointer, b0
  24.     FilePointer = FilePointer + 1
  25.     Read32 = LShift(b3, 24) + LShift(b2, 16) + LShift(b1, 8) + b0
  26. End Function
  27. Private Function Read16(filenumber) As Long
  28.     Get #filenumber, FilePointer, b1
  29.     FilePointer = FilePointer + 1
  30.     Get #filenumber, FilePointer, b0
  31.     FilePointer = FilePointer + 1
  32.     Read16 = b0 + LShift(b1, 8)
  33. End Function
  34. Function IsPSD(Filename As String) As Boolean
  35. On Error GoTo errorout:
  36.     Open Filename For Binary Access Read As #1
  37.         FilePointer = 1
  38.         IType = Read32(1)
  39.         If IType <> 943870035 Then IsPSD = False Else IsPSD = True
  40.     Close #1
  41.     Exit Function
  42. errorout:
  43. IsPSD = False
  44. Close #1
  45. End Function
  46.  
  47. Sub LoadPSD(Filename As String, pImage As ImageFile)
  48.  
  49.     Dim i As Long, j As Long, k As Long
  50.     Dim IType As Long
  51.     Dim ModeDataCount As Long, ResourceDataCount As Long, ReservedDataCount As Long
  52.     Dim PSDVersion As Integer
  53.     FilePointer = 1
  54.     ' Firstopen the file and get for us important entries from the header...
  55.     Open Filename For Binary Access Read As #1
  56.         IType = Read32(1)
  57.         If IType <> 943870035 Then Close #1: Exit Sub       'Not a PSD File.
  58.         PSDVersion = Read16(1)
  59.         If PSDVersion <> 1 Then Close #1: Exit Sub          'Incorrect PSD Version, MUST be 1.
  60.         ' Skip 6 Bytes, irrelevant info. Must be 0
  61.         FilePointer = FilePointer + 6
  62.         ImageInfo.ChannelCount = Read16(1)
  63.         If ImageInfo.ChannelCount < 0 Or ImageInfo.ChannelCount > 16 Then Close #1: Exit Sub 'Incorrect Channel Count
  64.         ImageInfo.Height = Read32(1)
  65.         ImageInfo.Width = Read32(1)
  66.         ImageInfo.BitsPerChannel = Read16(1)      'Supported values are 1,8 or 16
  67.         If ImageInfo.BitsPerChannel <> 8 Then Close #1: Exit Sub  'NO RGB COLOURS
  68.         ' Make sure the color mode is RGB.
  69.         ' Supported Modes are Bitmap=0, Grayscale=1, Indexed=2,RGB=3,CMYK=4,MultiChannel=7
  70.         ' Duotone=8,Lab=9
  71.         ImageInfo.Mode = Read16(1)
  72.         If ImageInfo.Mode <> 3 Then Close #1: Exit Sub      'ColorMode is Not RGB
  73.         ' Skip the Mode Data. (It's the palette for indexed color; other info for other modes.)
  74.         ModeDataCount = Read32(1)
  75.         If ModeDataCount <> 0 Then FilePointer = FilePointer + ModeDataCount
  76.         ' Skip the image resources. (resolution, pen tool paths, etc)
  77.         ResourceDataCount = Read32(1)
  78.         If ResourceDataCount <> 0 Then FilePointer = FilePointer + ResourceDataCount
  79.         ' Skip the reserved data.
  80.         ReservedDataCount = Read32(1)
  81.         If ReservedDataCount <> 0 Then FilePointer = FilePointer + ReservedDataCount
  82.         ' Find out if the data is compressed.
  83.         ImageInfo.Compression = Read16(1)
  84.         'Compression Type 0=Raw Data, RLE Compressed = 1
  85.         If ImageInfo.Compression > 1 Then Close #1: Exit Sub  'Compression Type Not Supported
  86.         ' Decode Image...
  87.         ReDim ImageInfo.Pixels(0 To (4 * ImageInfo.Height * ImageInfo.Width) + 2) As Byte
  88.         DecodePSD 1
  89.         Close #1
  90.         'Copy this data into our custom image object (which was passed).
  91.         pImage.ImageBPP = 24
  92.         pImage.ImageWidth = ImageInfo.Width
  93.         pImage.ImageHeight = ImageInfo.Height
  94.         Erase pImage.ImagePalette
  95.         ReDim pImage.ImageData(1 To ((pImage.ImageWidth * pImage.ImageHeight) * 3))
  96.         Dim offset1 As Long, Offset2 As Long
  97.         offset1 = 1
  98.         Offset2 = 0
  99.         For i = 0 To ImageInfo.Height - 1
  100.             For j = 0 To ImageInfo.Width - 1
  101.                 pImage.ImageData(offset1) = ImageInfo.Pixels((Offset2 * 4))
  102.                 offset1 = offset1 + 1
  103.                 pImage.ImageData(offset1) = ImageInfo.Pixels((Offset2 * 4) + 1)
  104.                 offset1 = offset1 + 1
  105.                 pImage.ImageData(offset1) = ImageInfo.Pixels((Offset2 * 4) + 2)
  106.                 offset1 = offset1 + 1
  107.                 'Skip Alpha Pixel (which would be (offset2 *4) +1)
  108.                 Offset2 = Offset2 + 1
  109.             Next j
  110.         Next i
  111.         Erase ImageInfo.Pixels
  112. End Sub
  113. Sub SavePSD(Filename As String, pImage As ImageFile)
  114.  
  115. End Sub
  116.  
  117. Sub DecodePSD(filenumber As Integer)
  118.     'NOTE: This function (including the DecodePSD function) are VERY slow whilst running in the IDE
  119.     '      For accurate load time results, please compile the EXE first.
  120.     Dim Default(0 To 3) As Long
  121.     Dim chn(0 To 3) As Long
  122.     Dim PixelCount As Long
  123.     Dim c As Long, n As Long, pn As Long, channel As Long, count As Long, ilen As Long, ival As Byte
  124.     Default(0) = 0
  125.     Default(1) = 0
  126.     Default(2) = 0
  127.     Default(3) = 255
  128.     chn(0) = 2
  129.     chn(1) = 1
  130.     chn(2) = 0
  131.     chn(3) = 3
  132.     Dim FileContainer() As Byte
  133.     ReDim FileContainer(0 To LOF(filenumber) - FilePointer)
  134.     Get #1, FilePointer, FileContainer
  135.     FilePointer = 0
  136.     PixelCount = ImageInfo.Width * ImageInfo.Height
  137.     If ImageInfo.Compression Then
  138.         FilePointer = FilePointer + ImageInfo.Height * ImageInfo.ChannelCount * 2
  139.         For c = 0 To 3
  140.             pn = 0
  141.             channel = chn(c)
  142.             If channel >= ImageInfo.ChannelCount Then
  143.                 For pn = 0 To PixelCount - 1
  144.                     ImageInfo.Pixels((pn * 4) + channel) = Default(channel)
  145.                 Next pn
  146.             Else
  147.                 count = 0
  148.                 Do Until (count >= PixelCount)
  149.                     ilen = FileContainer(FilePointer)
  150.                     FilePointer = FilePointer + 1
  151.                     If ilen = 128 Then
  152.                     ElseIf ilen < 128 Then
  153.                         ilen = ilen + 1
  154.                         count = count + ilen
  155.                         Do Until ilen = 0
  156.                             ImageInfo.Pixels((pn * 4) + channel) = FileContainer(FilePointer)
  157.                             FilePointer = FilePointer + 1
  158.                             pn = pn + 1
  159.                             ilen = ilen - 1
  160.                         Loop
  161.                     ElseIf ilen > 128 Then
  162.                         ilen = ilen Xor 255
  163.                         ilen = ilen + 2
  164.                         ival = FileContainer(FilePointer)
  165.                         FilePointer = FilePointer + 1
  166.                         count = count + ilen
  167.                         Do Until ilen = 0
  168.                             ImageInfo.Pixels((pn * 4) + channel) = ival
  169.                             pn = pn + 1
  170.                             ilen = ilen - 1
  171.                         Loop
  172.                     End If
  173.                 Loop
  174.             End If
  175.         Next c
  176.     Else
  177.         For c = 0 To 3
  178.             channel = chn(c)
  179.             If channel > ImageInfo.ChannelCount Then
  180.                 For pn = 0 To PixelCount - 1
  181.                     ImageInfo.Pixels((pn * 4) + channel) = Default(channel)
  182.                 Next pn
  183.             Else
  184.                 For n = 0 To PixelCount - 1
  185.                     ImageInfo.Pixels((n * 4) + channel) = FileContainer(FilePointer)
  186.                     FilePointer = FilePointer + 1
  187.                 Next n
  188.             End If
  189.         Next c
  190.     End If
  191.     Erase FileContainer
  192. End Sub
  193.  
  194.